Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

first step towards new Query types and logic

  • Loading branch information...
commit 3642cf75429a72897780e58915cb8a4444db8264 1 parent b34395b
@aristidb aristidb authored
View
43 Aws/Query.hs
@@ -13,24 +13,13 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as BU
import qualified Network.HTTP.Enumerator as HTTP
-class AsQuery r where
- type Info r :: *
- asQuery :: Info r -> r -> Query
-
-data Api
- = SimpleDB
- | S3
- deriving (Show)
-
-data Query
- = Query {
- api :: Api
- , method :: Method
+data SignedQuery
+ = SignedQuery {
+ method :: Method
, protocol :: Protocol
, host :: B.ByteString
, port :: Int
, path :: B.ByteString
- , canonicalizedResource :: B.ByteString
, subresource :: Maybe B.ByteString
, query :: [(B.ByteString, B.ByteString)]
, date :: Maybe UTCTime
@@ -38,28 +27,24 @@ data Query
, contentType :: Maybe B.ByteString
, contentMd5 :: Maybe B.ByteString
, body :: L.ByteString
- , stringToSign :: Maybe B.ByteString
+ , stringToSign :: B.ByteString
}
deriving (Show)
-instance AsQuery Query where
- type Info Query = ()
- asQuery _ = id
-
-addQuery :: [(B.ByteString, B.ByteString)] -> Query -> Query
+addQuery :: [(B.ByteString, B.ByteString)] -> SignedQuery -> SignedQuery
addQuery xs q = q { query = xs ++ query q }
-addQueryItem :: B.ByteString -> B.ByteString -> Query -> Query
+addQueryItem :: B.ByteString -> B.ByteString -> SignedQuery -> SignedQuery
addQueryItem name value = addQuery [(name, value)]
-addQueryIf :: Bool -> [(B.ByteString, B.ByteString)] -> Query -> Query
+addQueryIf :: Bool -> [(B.ByteString, B.ByteString)] -> SignedQuery -> SignedQuery
addQueryIf True = addQuery
addQueryIf False = const id
-addQueryUnless :: Bool -> [(B.ByteString, B.ByteString)] -> Query -> Query
+addQueryUnless :: Bool -> [(B.ByteString, B.ByteString)] -> SignedQuery -> SignedQuery
addQueryUnless = addQueryIf . not
-addQueryMaybe :: (a -> B.ByteString) -> (B.ByteString, Maybe a) -> Query -> Query
+addQueryMaybe :: (a -> B.ByteString) -> (B.ByteString, Maybe a) -> SignedQuery -> SignedQuery
addQueryMaybe f (name, Just a) q = q { query = (name, f a) : query q }
addQueryMaybe _ (_, Nothing) q = q
@@ -71,7 +56,7 @@ queryList f prefix xs = concat $ zipWith combine prefixList (map f xs)
where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..]
combine pf = map $ first (pf `dot`)
-addQueryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> Query -> Query
+addQueryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> SignedQuery -> SignedQuery
addQueryList f prefix xs = addQuery $ queryList f prefix xs
awsBool :: Bool -> B.ByteString
@@ -84,8 +69,8 @@ awsTrue = awsBool True
awsFalse :: B.ByteString
awsFalse = awsBool False
-queryToHttpRequest :: Query -> HTTP.Request
-queryToHttpRequest Query{..}
+queryToHttpRequest :: SignedQuery -> HTTP.Request
+queryToHttpRequest SignedQuery{..}
= HTTP.Request {
HTTP.method = httpMethod method
, HTTP.secure = case protocol of
@@ -109,8 +94,8 @@ queryToHttpRequest Query{..}
PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"
_ -> contentType
-queryToUri :: Query -> B.ByteString
-queryToUri Query{..}
+queryToUri :: SignedQuery -> B.ByteString
+queryToUri SignedQuery{..}
= B.concat [
case protocol of
HTTP -> "http://"
View
2  Aws/S3/GetService.hs
@@ -9,6 +9,7 @@ import Data.ByteString.Lazy.Char8 ({- IsString -})
data GetService = GetService
+{-
instance AsQuery GetService where
type Info GetService = () -- < preliminary
asQuery _ _ = Query {
@@ -28,3 +29,4 @@ instance AsQuery GetService where
, body = ""
, stringToSign = Nothing
}
+-}
View
103 Aws/Signature.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards, OverloadedStrings, TypeFamilies #-}
module Aws.Signature
where
@@ -18,6 +18,12 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Serialize as Serialize
+data TimeInfo
+ = Timestamp
+ | ExpiresAt { fromExpiresAt :: UTCTime }
+ | ExpiresIn { fromExpiresIn :: NominalDiffTime }
+ deriving (Show)
+
data AbsoluteTimeInfo
= AbsoluteTimestamp { fromAbsoluteTimestamp :: UTCTime }
| AbsoluteExpires { fromAbsoluteExpires :: UTCTime }
@@ -27,10 +33,31 @@ fromAbsoluteTimeInfo :: AbsoluteTimeInfo -> UTCTime
fromAbsoluteTimeInfo (AbsoluteTimestamp time) = time
fromAbsoluteTimeInfo (AbsoluteExpires time) = time
-data TimeInfo
- = Timestamp
- | ExpiresAt { fromExpiresAt :: UTCTime }
- | ExpiresIn { fromExpiresIn :: NominalDiffTime }
+makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo
+makeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now
+makeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t
+makeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now
+
+data SignatureData
+ = SignatureData {
+ signatureTimeInfo :: AbsoluteTimeInfo
+ , signatureTime :: UTCTime
+ , signatureCredentials :: Credentials
+ }
+
+signatureData :: TimeInfo -> Credentials -> IO SignatureData
+signatureData rti cr = do
+ now <- getCurrentTime
+ let ti = makeAbsoluteTimeInfo rti now
+ return SignatureData { signatureTimeInfo = ti, signatureTime = now, signatureCredentials = cr }
+
+class SignQuery r where
+ type Info r :: *
+ signQuery :: Info r -> r -> SignatureData -> SignedQuery
+
+data Api
+ = SimpleDB
+ | S3
deriving (Show)
data AuthorizationHash
@@ -42,12 +69,8 @@ amzHash :: AuthorizationHash -> B.ByteString
amzHash HmacSHA1 = "HmacSHA1"
amzHash HmacSHA256 = "HmacSHA256"
-makeAbsoluteTimeInfo :: TimeInfo -> UTCTime -> AbsoluteTimeInfo
-makeAbsoluteTimeInfo Timestamp now = AbsoluteTimestamp now
-makeAbsoluteTimeInfo (ExpiresAt t) _ = AbsoluteExpires t
-makeAbsoluteTimeInfo (ExpiresIn s) now = AbsoluteExpires $ addUTCTime s now
-
-calculateStringToSign :: AbsoluteTimeInfo -> Query -> B.ByteString
+{-
+calculateStringToSign :: AbsoluteTimeInfo -> SignedQuery -> B.ByteString
calculateStringToSign ti Query{..}
= case api of
SimpleDB -> B.intercalate "\n" [httpMethod method
@@ -63,6 +86,7 @@ calculateStringToSign ti Query{..}
, [] -- canonicalized AMZ headers
, [canonicalizedResource]]
where sortedQuery = sort query
+-}
signature :: Credentials -> AuthorizationHash -> B.ByteString -> B.ByteString
signature cr ah input = Base64.encode sig
@@ -73,6 +97,7 @@ signature cr ah input = Base64.encode sig
computeSig t = Serialize.encode (HMAC.hmac' key input `asTypeOf` t)
key = HMAC.MacKey (secretAccessKey cr)
+{-
signQuery' :: AbsoluteTimeInfo -> UTCTime -> Credentials -> Query -> Query
signQuery' ti now cr query
= flip execState query $ do
@@ -96,35 +121,39 @@ signQuery' ti now cr query
addQueryItemM n v = modify $ addQueryItem n v
- authorizationQuery = (authorizationQueryPrepare, authorizationQueryComplete)
- authorizationQueryPrepare = do
- case ti of
- AbsoluteTimestamp time ->
- addQueryItemM "Timestamp" $ fmtAmzTime time
- AbsoluteExpires time ->
- addQueryItemM "Expires" $ case api' of
- SimpleDB -> fmtAmzTime time
- S3 -> fmtTimeEpochSeconds time
- addQueryItemM "AWSAccessKeyId" $ accessKeyID cr
- addQueryItemM "SignatureMethod" $ amzHash ah
- case api' of
- SimpleDB -> addQueryItemM "SignatureVersion" "2"
- S3 -> return ()
- authorizationQueryComplete sig = do
- addQueryItemM "Signature" sig
-
- authorizationHeader = (authorizationHeaderPrepare, authorizationHeaderComplete)
- authorizationHeaderPrepare = return ()
- authorizationHeaderComplete sig = do
- modify $ \q -> q { authorization = Just $ B.concat [
- "AWS "
- , accessKeyID cr
- , ":"
- , sig
- ] }
signQuery :: MonadIO io => TimeInfo -> Credentials -> Query -> io Query
signQuery rti cr query = do
now <- liftIO getCurrentTime
let ti = makeAbsoluteTimeInfo rti now
return $ signQuery' ti now cr query
+-}
+
+authorizationQueryPrepare :: Api -> AuthorizationHash -> SignatureData -> [(B.ByteString, B.ByteString)]
+authorizationQueryPrepare api' ah SignatureData { signatureTimeInfo = ti, signatureCredentials = cr }
+ = concat [
+ case ti of
+ AbsoluteTimestamp time ->
+ [("Timestamp", fmtAmzTime time)]
+ AbsoluteExpires time ->
+ [("Expires", case api' of
+ SimpleDB -> fmtAmzTime time
+ S3 -> fmtTimeEpochSeconds time)]
+ , [("AWSAccessKeyId", accessKeyID cr)]
+ , [("SignatureMethod", amzHash ah)]
+ , case api' of
+ SimpleDB -> [("SignatureVersion", "2")]
+ S3 -> []
+ ]
+
+authorizationQueryComplete :: B.ByteString -> [(B.ByteString, B.ByteString)]
+authorizationQueryComplete sig = [("Signature", sig)]
+
+authorizationHeaderComplete :: SignatureData -> B.ByteString -> SignedQuery -> SignedQuery
+authorizationHeaderComplete SignatureData { signatureCredentials = cr } sig q
+ = q { authorization = Just $ B.concat [
+ "AWS "
+ , accessKeyID cr
+ , ":"
+ , sig
+ ] }
View
2  Aws/SimpleDb.hs
@@ -10,6 +10,7 @@ module Aws.SimpleDb
, module Aws.SimpleDb.ListDomains
, module Aws.SimpleDb.Model
, module Aws.SimpleDb.PutAttributes
+, module Aws.SimpleDb.Query
, module Aws.SimpleDb.Response
, module Aws.SimpleDb.Select
)
@@ -25,5 +26,6 @@ import Aws.SimpleDb.Info
import Aws.SimpleDb.ListDomains
import Aws.SimpleDb.Model
import Aws.SimpleDb.PutAttributes
+import Aws.SimpleDb.Query
import Aws.SimpleDb.Response
import Aws.SimpleDb.Select
View
20 Aws/SimpleDb/Info.hs
@@ -40,21 +40,5 @@ sdbHttpsGet endpoint = SdbInfo HTTPS Get endpoint (defaultPort HTTPS)
sdbHttpsPost :: B.ByteString -> SdbInfo
sdbHttpsPost endpoint = SdbInfo HTTPS PostQuery endpoint (defaultPort HTTPS)
-sdbiBaseQuery :: SdbInfo -> Query
-sdbiBaseQuery SdbInfo{..} = Query {
- api = SimpleDB
- , method = sdbiHttpMethod
- , protocol = sdbiProtocol
- , host = sdbiHost
- , port = sdbiPort
- , path = "/"
- , canonicalizedResource = ""
- , subresource = Nothing
- , query = [("Version", "2009-04-15")]
- , date = Nothing
- , authorization = Nothing
- , contentType = Nothing
- , contentMd5 = Nothing
- , body = L.empty
- , stringToSign = Nothing
- }
+{-
+-}
View
37 Aws/SimpleDb/Query.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Aws.SimpleDb.Query
+where
+
+import Aws.Http
+import Aws.Query
+import Aws.Signature
+import Aws.SimpleDb.Info
+import Aws.Util
+import Data.List
+import qualified Data.ByteString as B
+
+{-
+sdbiBaseQuery :: SdbInfo -> SignedQuery
+sdbiBaseQuery SdbInfo{..} = SignedQuery {
+ method = sdbiHttpMethod
+ , protocol = sdbiProtocol
+ , host = sdbiHost
+ , port = sdbiPort
+ , path = "/"
+ , query = [("Version", "2009-04-15")]
+ }
+-}
+
+sdbSignQuery :: [(B.ByteString, B.ByteString)] -> SdbInfo -> SignatureData -> SignedQuery
+sdbSignQuery q si sd
+ = undefined
+ where
+ q' = sort $ q ++ ("Version", "2009-04-15") : authorizationQueryPrepare SimpleDB HmacSHA256 sd
+ method = sdbiHttpMethod si
+ host = sdbiHost si
+ path = "/"
+ sig = signature (signatureCredentials sd) HmacSHA256 stringToSign
+ stringToSign = B.intercalate "\n" [httpMethod method
+ , host
+ , path
+ , urlEncodeVarsBS False q']
View
7 Aws/Transaction.hs
@@ -11,13 +11,14 @@ import Data.Maybe
import qualified Data.Enumerator as En
import qualified Network.HTTP.Enumerator as HTTP
-class (AsQuery r, ResponseIteratee a)
+class (SignQuery r, ResponseIteratee a)
=> Transaction r a | r -> a, a -> r
transact :: (Transaction r a)
=> TimeInfo -> Credentials -> Info r -> r -> IO a
transact ti cr i r = do
- q <- signQuery ti cr $ asQuery i r
- debugPrint "String to sign" $ fromMaybe "NOTHING" $ stringToSign q
+ sd <- signatureData ti cr
+ let q = signQuery i r sd
+ debugPrint "String to sign" $ stringToSign q
let httpRequest = queryToHttpRequest q
En.run_ $ HTTP.httpRedirect httpRequest responseIteratee
View
1  aws.cabal
@@ -71,6 +71,7 @@ Library
Aws.SimpleDb.ListDomains,
Aws.SimpleDb.Model,
Aws.SimpleDb.PutAttributes,
+ Aws.SimpleDb.Query,
Aws.SimpleDb.Response,
Aws.SimpleDb.Select,
Aws.Transaction,
Please sign in to comment.
Something went wrong with that request. Please try again.