first step towards new Query types and logic

Aws/Query.hs

@@ -13,53 +13,38 @@ 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
       , authorization :: Maybe B.ByteString
       , 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://"

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
                   }
+-}

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
+                        ] }

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

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
-                            }
+{-
+-}

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']

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

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,