Make signature V4 independent of S3ReqInfo (#88)

- Rename RequestInfo to S3ReqInfo

src/Network/Minio/API.hs

@@ -16,7 +16,7 @@
 
 module Network.Minio.API
   ( connect
-  , RequestInfo(..)
+  , S3ReqInfo(..)
   , runMinio
   , executeRequest
   , mkStreamRequest
@@ -35,6 +35,7 @@ import           Data.Conduit.Binary       (sourceHandleRange)
 import           Data.Default              (def)
 import qualified Data.Map                  as Map
 import qualified Data.Text                 as T
+import qualified Data.Time.Clock           as Time
 
 import           Network.HTTP.Conduit      (Response)
 import qualified Network.HTTP.Conduit      as NC
@@ -82,7 +83,7 @@ getLocation bucket = do
 
 -- | Looks for region in RegionMap and updates it using getLocation if
 -- absent.
-discoverRegion :: RequestInfo -> Minio (Maybe Region)
+discoverRegion :: S3ReqInfo -> Minio (Maybe Region)
 discoverRegion ri = runMaybeT $ do
   bucket <- MaybeT $ return $ riBucket ri
   regionMay <- lift $ lookupRegionCache bucket
@@ -93,7 +94,7 @@ discoverRegion ri = runMaybeT $ do
         ) return regionMay
 
 
-buildRequest :: RequestInfo -> Minio NC.Request
+buildRequest :: S3ReqInfo -> Minio NC.Request
 buildRequest ri = do
   maybe (return ()) checkBucketNameValidity $ riBucket ri
   maybe (return ()) checkObjectNameValidity $ riObject ri
@@ -128,6 +129,8 @@ buildRequest ri = do
                    -- otherwise compute sha256
                    | otherwise -> getPayloadSHA256Hash (riPayload ri)
 
+  timeStamp <- liftIO Time.getCurrentTime
+
   let hostHeader = (hHost, getHostAddr ci)
       newRi = ri { riPayloadHash = Just sha256Hash
                  , riHeaders = hostHeader
@@ -136,28 +139,36 @@ buildRequest ri = do
                  , riRegion = region
                  }
       newCi = ci { connectHost = regionHost }
+      signReq = toRequest newCi newRi
+      sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
+           timeStamp (riRegion newRi) Nothing (riPayloadHash newRi)
+  let signHeaders = signV4 sp signReq
 
-  signHeaders <- liftIO $ signV4 newCi newRi Nothing
+  -- Update signReq with Authorization header containing v4 signature
+  return signReq {
+      NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders
+      }
+  where
+    toRequest :: ConnectInfo -> S3ReqInfo -> NC.Request
+    toRequest ci s3Req = NC.defaultRequest {
+          NC.method = riMethod s3Req
+        , NC.secure = connectIsSecure ci
+        , NC.host = encodeUtf8 $ connectHost ci
+        , NC.port = connectPort ci
+        , NC.path = getS3Path (riBucket s3Req) (riObject s3Req)
+        , NC.requestHeaders = riHeaders s3Req
+        , NC.queryString = HT.renderQuery False $ riQueryParams s3Req
+        , NC.requestBody = getRequestBody (riPayload s3Req)
+        }
 
-  return NC.defaultRequest {
+executeRequest :: S3ReqInfo -> Minio (Response LByteString)
-      NC.method = riMethod newRi
-    , NC.secure = connectIsSecure newCi
-    , NC.host = encodeUtf8 $ connectHost newCi
-    , NC.port = connectPort newCi
-    , NC.path = getPathFromRI newRi
-    , NC.queryString = HT.renderQuery False $ riQueryParams newRi
-    , NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders
-    , NC.requestBody = getRequestBody (riPayload newRi)
-    }
-
-executeRequest :: RequestInfo -> Minio (Response LByteString)
 executeRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
   httpLbs req mgr
 
 
-mkStreamRequest :: RequestInfo
+mkStreamRequest :: S3ReqInfo
                 -> Minio (Response (C.ConduitM () ByteString Minio ()))
 mkStreamRequest ri = do
   req <- buildRequest ri

src/Network/Minio/Data.hs

@@ -472,7 +472,7 @@ data Payload = PayloadBS ByteString
 instance Default Payload where
   def = PayloadBS ""
 
-data RequestInfo = RequestInfo {
+data S3ReqInfo = S3ReqInfo {
     riMethod        :: Method
   , riBucket        :: Maybe Bucket
   , riObject        :: Maybe Object
@@ -484,15 +484,12 @@ data RequestInfo = RequestInfo {
   , riNeedsLocation :: Bool
   }
 
-instance Default RequestInfo where
+instance Default S3ReqInfo where
-  def = RequestInfo HT.methodGet def def def def def Nothing def True
+  def = S3ReqInfo HT.methodGet def def def def def Nothing def True
 
-getPathFromRI :: RequestInfo -> ByteString
+getS3Path :: Maybe Bucket -> Maybe Object -> ByteString
-getPathFromRI ri =
+getS3Path b o =
-  let
+  let segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)
-    b = riBucket ri
-    o = riObject ri
-    segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)
   in
     B.concat ["/", B.intercalate "/" segments]
 

src/Network/Minio/PresignedOperations.hs

@@ -39,10 +39,10 @@ module Network.Minio.PresignedOperations
 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as Json
 import           Data.ByteString.Builder   (byteString, toLazyByteString)
-import           Data.Default              (def)
 import qualified Data.Map.Strict           as Map
 import qualified Data.Text                 as T
 import qualified Data.Time                 as Time
+import qualified Network.HTTP.Conduit      as NC
 import qualified Network.HTTP.Types        as HT
 import           Network.HTTP.Types.Header (hHost)
 
@@ -72,24 +72,31 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
 
   let
     hostHeader = (hHost, getHostAddr ci)
-    ri = def { riMethod = method
+    req = NC.defaultRequest {
-             , riBucket = bucket
+          NC.method = method
-             , riObject = object
+        , NC.secure = connectIsSecure ci
-             , riQueryParams = extraQuery
+        , NC.host = encodeUtf8 $ connectHost ci
-             , riHeaders = hostHeader : extraHeaders
+        , NC.port = connectPort ci
-             , riRegion = Just $ maybe (connectRegion ci) identity region
+        , NC.path = getS3Path bucket object
-             }
+        , NC.requestHeaders = hostHeader : extraHeaders
+        , NC.queryString = HT.renderQuery True extraQuery
+        }
+  ts <- liftIO Time.getCurrentTime
 
-  signPairs <- liftIO $ signV4 ci ri (Just expiry)
+  let sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
+           ts region (Just expiry) Nothing
 
-  let
+      signPairs = signV4 sp req
-    qpToAdd = (fmap . fmap) Just signPairs
-    queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd)
-    scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
 
-  return $ toS $ toLazyByteString $
+      qpToAdd = (fmap . fmap) Just signPairs
-    scheme <> byteString (getHostAddr ci) <> byteString (getPathFromRI ri) <>
+      queryStr = HT.renderQueryBuilder True
-    queryStr
+                 ((HT.parseQuery $ NC.queryString req) ++ qpToAdd)
+      scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
+
+  return $ toS $ toLazyByteString $ scheme
+     <> byteString (getHostAddr ci)
+     <> byteString (getS3Path bucket object)
+     <> queryStr
 
 -- | Generate a URL with authentication signature to PUT (upload) an
 -- object. Any extra headers if passed, are signed, and so they are
@@ -258,8 +265,10 @@ presignedPostPolicy p = do
     ppWithCreds = p {
       conditions = conditions p ++ extraConditions
       }
-    signData = signV4PostPolicy (showPostPolicy ppWithCreds)
+    sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
-               signTime ci
+         signTime (Just $ connectRegion ci) Nothing Nothing
+    signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp
+
 
     -- compute form-data
     mkPair (PPCStartsWith k v) = Just (k, v)

src/Network/Minio/Sign/V4.hs

@@ -17,7 +17,6 @@
 module Network.Minio.Sign.V4
   (
     signV4
-  , signV4AtTime
   , signV4PostPolicy
   , mkScope
   , getHeadersToSign
@@ -26,21 +25,24 @@ module Network.Minio.Sign.V4
   , mkSigningKey
   , computeSignature
   , SignV4Data(..)
+  , SignParams(..)
   , debugPrintSignV4Data
   ) where
 
-import qualified Data.ByteString as B
+import qualified Data.ByteString               as B
-import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Base64        as Base64
-import           Data.CaseInsensitive (mk)
+import qualified Data.ByteString.Char8         as B8
-import qualified Data.CaseInsensitive as CI
+import           Data.CaseInsensitive          (mk)
-import qualified Data.Set as Set
+import qualified Data.CaseInsensitive          as CI
-import qualified Data.Time as Time
+import qualified Data.Map.Strict               as Map
-import qualified Data.ByteString.Base64 as Base64
+import qualified Data.Set                      as Set
-import qualified Data.Map.Strict as Map
+import qualified Data.Time                     as Time
-import           Network.HTTP.Types (Header)
+import qualified Network.HTTP.Conduit          as NC
-import qualified Network.HTTP.Types.Header as H
+import           Network.HTTP.Types            (Header, parseQuery)
+import qualified Network.HTTP.Types.Header     as H
 
 import           Lib.Prelude
+
 import           Network.Minio.Data
 import           Network.Minio.Data.ByteString
 import           Network.Minio.Data.Crypto
@@ -57,14 +59,23 @@ ignoredHeaders = Set.fromList $ map CI.foldedCase
                  ]
 
 data SignV4Data = SignV4Data {
-    sv4SignTime :: UTCTime
+      sv4SignTime         :: UTCTime
-  , sv4Scope :: ByteString
+    , sv4Scope            :: ByteString
-  , sv4CanonicalRequest :: ByteString
+    , sv4CanonicalRequest :: ByteString
-  , sv4HeadersToSign :: [(ByteString, ByteString)]
+    , sv4HeadersToSign    :: [(ByteString, ByteString)]
-  , sv4Output :: [(ByteString, ByteString)]
+    , sv4Output           :: [(ByteString, ByteString)]
-  , sv4StringToSign :: ByteString
+    , sv4StringToSign     :: ByteString
-  , sv4SigningKey :: ByteString
+    , sv4SigningKey       :: ByteString
-  } deriving (Show)
+    } deriving (Show)
+
+data SignParams = SignParams {
+      spAccessKey   :: Text
+    , spSecretKey   :: Text
+    , spTimeStamp   :: UTCTime
+    , spRegion      :: Maybe Region
+    , spExpirySecs  :: Maybe Int
+    , spPayloadHash :: Maybe ByteString
+    } deriving (Show)
 
 debugPrintSignV4Data :: SignV4Data -> IO ()
 debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
@@ -83,40 +94,33 @@ debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
       mapM_ (\x -> B.putStr $ B.concat [show x,  " "]) $ B.unpack b
       B8.putStrLn ""
 
--- | Given MinioClient and request details, including request method,
+-- | Given SignParams and request details, including request method,
 -- request path, headers, query params and payload hash, generates an
 -- updated set of headers, including the x-amz-date header and the
 -- Authorization header, which includes the signature.
-signV4 :: ConnectInfo -> RequestInfo -> Maybe Int
+--
-       -> IO [(ByteString, ByteString)]
+-- For normal requests (i.e. without an expiry time), the output is
-signV4 !ci !ri !expiry = do
+-- the list of headers to add to authenticate the request.
-  timestamp <- Time.getCurrentTime
-  let signData = signV4AtTime timestamp ci ri expiry
-  -- debugPrintSignV4Data signData
-  return $ sv4Output signData
-
--- | Takes a timestamp, server params and request params and generates
--- AWS Sign V4 data. For normal requests (i.e. without an expiry
--- time), the output is the list of headers to add to authenticate the
--- request.
 --
 -- If `expiry` is not Nothing, it is assumed that a presigned request
 -- is being created. The expiry is interpreted as an integer number of
 -- seconds. The output will be the list of query-parameters to add to
 -- the request.
-signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> Maybe Int
+
-             -> SignV4Data
+signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]
-signV4AtTime ts ci ri expiry =
+signV4 !sp !req =
   let
-    region = maybe (connectRegion ci) identity $ riRegion ri
+    region = fromMaybe "" $ spRegion sp
+    ts = spTimeStamp sp
     scope = mkScope ts region
-    accessKey = toS $ connectAccessKey ci
+    accessKey = toS $ spAccessKey sp
-    secretKey = toS $ connectSecretKey ci
+    secretKey = toS $ spSecretKey sp
+    expiry = spExpirySecs sp
 
     -- headers to be added to the request
     datePair = ("X-Amz-Date", awsTimeFormatBS ts)
-    computedHeaders = riHeaders ri ++
+    computedHeaders = NC.requestHeaders req ++
-                      if isJust expiry
+                      if isJust $ expiry
                       then []
                       else [(\(x, y) -> (mk x, y)) datePair]
     headersToSign = getHeadersToSign computedHeaders
@@ -130,13 +134,13 @@ signV4AtTime ts ci ri expiry =
              , ("X-Amz-Expires", maybe "" show expiry)
              , ("X-Amz-SignedHeaders", signedHeaderKeys)
              ]
-    finalQP = riQueryParams ri ++
+    finalQP = parseQuery (NC.queryString req)  ++
               if isJust expiry
               then (fmap . fmap) Just authQP
               else []
 
     -- 1. compute canonical request
-    canonicalRequest = mkCanonicalRequest (ri {riQueryParams = finalQP})
+    canonicalRequest = mkCanonicalRequest sp (NC.setQueryString finalQP req)
                        headersToSign
 
     -- 2. compute string to sign
@@ -167,9 +171,7 @@ signV4AtTime ts ci ri expiry =
              else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,
                    datePair]
 
-  in
+  in output
-    SignV4Data ts scope canonicalRequest headersToSign output
-    stringToSign signingKey
 
 
 mkScope :: UTCTime -> Region -> ByteString
@@ -185,15 +187,15 @@ getHeadersToSign !h =
   filter (flip Set.notMember ignoredHeaders . fst) $
   map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
 
-mkCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)]
+mkCanonicalRequest :: SignParams -> NC.Request -> [(ByteString, ByteString)]
                     -> ByteString
-mkCanonicalRequest !ri !headersForSign =
+mkCanonicalRequest !sp !req !headersForSign =
   let
     canonicalQueryString = B.intercalate "&" $
       map (\(x, y) -> B.concat [x, "=", y]) $
       sort $ map (\(x, y) ->
                     (uriEncode True x, maybe "" (uriEncode True) y)) $
-      riQueryParams ri
+      (parseQuery $ NC.queryString req)
 
     sortedHeaders = sort headersForSign
 
@@ -204,12 +206,12 @@ mkCanonicalRequest !ri !headersForSign =
 
   in
     B.intercalate "\n"
-    [ riMethod ri
+    [ NC.method req
-    , uriEncode False $ getPathFromRI ri
+    , uriEncode False $ NC.path req
     , canonicalQueryString
     , canonicalHeaders
     , signedHeaders
-    , maybe "UNSIGNED-PAYLOAD" identity $ riPayloadHash ri
+    , maybe "UNSIGNED-PAYLOAD" identity $ spPayloadHash sp
     ]
 
 mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
@@ -233,13 +235,13 @@ computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key
 -- | Takes a validated Post Policy JSON bytestring, the signing time,
 -- and ConnInfo and returns form-data for the POST upload containing
 -- just the signature and the encoded post-policy.
-signV4PostPolicy :: ByteString -> UTCTime -> ConnectInfo
+signV4PostPolicy :: ByteString -> SignParams
                  -> Map.Map Text ByteString
-signV4PostPolicy !postPolicyJSON !signTime !ci =
+signV4PostPolicy !postPolicyJSON !sp =
   let
     stringToSign = Base64.encode postPolicyJSON
-    region = connectRegion ci
+    region = fromMaybe "" $ spRegion sp
-    signingKey = mkSigningKey signTime region $ toS $ connectSecretKey ci
+    signingKey = mkSigningKey (spTimeStamp sp) region $ toS $ spSecretKey sp
     signature = computeSignature stringToSign signingKey
   in
     Map.fromList [ ("x-amz-signature", signature)