Add presigned operations APIs (minio#56)

This change adds 3 functions to main API: presignedGetObjectURL,
presignedPutObjectURL and presignedHeadObjectURL.

A fourth more generic API is added to `Network.Minio.S3API` -
makePresignedURL.

Additionally, refactors signing code for readability and the ability
to reuse for pre-signing.

minio-hs.cabal

@@ -65,6 +65,7 @@ library
   default-language:    Haskell2010
   default-extensions:  FlexibleContexts
                      , FlexibleInstances
+                     , BangPatterns
                      , MultiParamTypeClasses
                      , MultiWayIf
                      , NoImplicitPrelude
@@ -84,7 +85,8 @@ test-suite minio-hs-live-server-test
   main-is:             LiveServer.hs
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
-  default-extensions:  FlexibleContexts
+  default-extensions:  BangPatterns
+                     , FlexibleContexts
                      , FlexibleInstances
                      , OverloadedStrings
                      , NoImplicitPrelude
@@ -194,7 +196,8 @@ test-suite minio-hs-test
                      , xml-conduit
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
-  default-extensions:  FlexibleContexts
+  default-extensions:  BangPatterns
+                     , FlexibleContexts
                      , FlexibleInstances
                      , OverloadedStrings
                      , NoImplicitPrelude

src/Lib/Prelude.hs

@@ -14,17 +14,12 @@
 -- limitations under the License.
 --
 
-{-
-Welcome to your custom Prelude
-Export here everything that should always be in your library scope
-For more info on what is exported by Protolude check:
-https://github.com/sdiehl/protolude/blob/master/Symbols.md
--}
 module Lib.Prelude
     ( module Exports
     , both
 
     , format
+    , formatBS
     ) where
 
 import           Protolude as Exports
@@ -37,10 +32,12 @@ import           Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)
 import           Data.Text.Format as Exports (Shown(..))
 import qualified Data.Text.Format as TF
 import           Data.Text.Format.Params (Params)
-import qualified Data.Text.Lazy as LT
 
 format :: Params ps => TF.Format -> ps -> Text
-format f args = LT.toStrict $ TF.format f args
+format f args = toS $ TF.format f args
+
+formatBS :: Params ps => TF.Format -> ps -> ByteString
+formatBS f args = toS $ TF.format f args
 
 -- import Data.Tuple as Exports (uncurry)
 

src/Network/Minio.hs

@@ -75,6 +75,12 @@ module Network.Minio
   , statObject
   , removeIncompleteUpload
 
+  -- * Presigned Operations
+  -------------------------
+  , UrlExpiry
+  , presignedPutObjectURL
+  , presignedGetObjectURL
+  , presignedHeadObjectURL
   ) where
 
 {-
@@ -145,7 +151,7 @@ statObject = headObject
 -- configured in ConnectInfo, which is by default, the US Standard
 -- Region.
 makeBucket :: Bucket -> Maybe Region -> Minio ()
-makeBucket bucket regionMay= do
+makeBucket bucket regionMay = do
   region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay
   putBucket bucket region
   modify (Map.insert bucket region)

src/Network/Minio/API.hs

@@ -39,6 +39,7 @@ import qualified Data.ByteString as B
 import           Network.HTTP.Conduit (Response)
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
+import Network.HTTP.Types.Header (hHost)
 
 import           Lib.Prelude
 
@@ -122,13 +123,18 @@ buildRequest ri = do
 
 
   sha256Hash <- getPayloadSHA256Hash (riPayload ri)
-  let newRi = ri { riPayloadHash = sha256Hash
-                 , riHeaders = sha256Header sha256Hash : riHeaders ri
+  let hostHeader = (hHost, formatBS "{}:{}" [connectHost ci,
+                                             show $ connectPort ci])
+
+      newRi = ri { riPayloadHash = Just sha256Hash
+                 , riHeaders = hostHeader
+                             : sha256Header sha256Hash
+                             : riHeaders ri
                  , riRegion = region
                  }
       newCi = ci { connectHost = regionHost }
 
-  reqHeaders <- liftIO $ signV4 newCi newRi
+  signHeaders <- liftIO $ signV4 newCi newRi Nothing
 
   return NC.defaultRequest {
       NC.method = riMethod newRi
@@ -137,7 +143,7 @@ buildRequest ri = do
     , NC.port = connectPort newCi
     , NC.path = getPathFromRI newRi
     , NC.queryString = HT.renderQuery False $ riQueryParams newRi
-    , NC.requestHeaders = reqHeaders
+    , NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders
     , NC.requestBody = getRequestBody (riPayload newRi)
     }
 

src/Network/Minio/Data.hs

@@ -233,10 +233,10 @@ data ObjectInfo = ObjectInfo {
   } deriving (Show, Eq)
 
 data CopyPartSource = CopyPartSource {
-    cpSource :: Text -- | formatted like "\/sourceBucket\/sourceObject"
-  , cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten
-                                          -- bytes of the source
-                                          -- object
+    -- | formatted like "\/sourceBucket\/sourceObject"
+    cpSource :: Text
+    -- | (0, 9) means first ten bytes of the source object
+  , cpSourceRange :: Maybe (Int64, Int64)
   , cpSourceIfMatch :: Maybe Text
   , cpSourceIfNoneMatch :: Maybe Text
   , cpSourceIfUnmodifiedSince :: Maybe UTCTime
@@ -289,19 +289,26 @@ data RequestInfo = RequestInfo {
   , riQueryParams :: Query
   , riHeaders :: [Header]
   , riPayload :: Payload
-  , riPayloadHash :: ByteString
+  , riPayloadHash :: Maybe ByteString
   , riRegion :: Maybe Region
   , riNeedsLocation :: Bool
   }
 
 instance Default RequestInfo where
-  def = RequestInfo HT.methodGet def def def def def "" def True
+  def = RequestInfo HT.methodGet def def def def def Nothing def True
 
 getPathFromRI :: RequestInfo -> ByteString
-getPathFromRI ri = B.concat parts
-  where
-    objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri
-    parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri
+getPathFromRI ri =
+  let
+    b = riBucket ri
+    o = riObject ri
+    segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)
+  in
+    B.concat ["/", B.intercalate "/" segments]
+
+-- | Time to expire for a presigned URL. It interpreted as a number of
+-- seconds. The maximum duration that can be specified is 7 days.
+type UrlExpiry = Int
 
 type RegionMap = Map.Map Bucket Region
 

src/Network/Minio/Errors.hs

@@ -37,6 +37,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
            | MErrVXmlParse Text
            | MErrVInvalidBucketName Text
            | MErrVInvalidObjectName Text
+           | MErrVInvalidUrlExpiry Int
   deriving (Show, Eq)
 
 instance Exception MErrV

src/Network/Minio/S3API.hs

@@ -64,19 +64,29 @@ module Network.Minio.S3API
   , deleteBucket
   , deleteObject
 
+  -- * Presigned URL Operations
+  -----------------------------
+  , UrlExpiry
+  , makePresignedURL
+  , presignedPutObjectURL
+  , presignedGetObjectURL
+  , presignedHeadObjectURL
   ) where
 
 import           Control.Monad.Catch (catches, Handler(..))
 import qualified Data.Conduit as C
 import           Data.Default (def)
+import           Data.ByteString.Builder (toLazyByteString, byteString)
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
 import           Network.HTTP.Types.Status (status404)
+import           Network.HTTP.Types.Header (hHost)
 
 import           Lib.Prelude hiding (catches)
 
 import           Network.Minio.API
 import           Network.Minio.Data
+import           Network.Minio.Sign.V4
 import           Network.Minio.Errors
 import           Network.Minio.Utils
 import           Network.Minio.XmlGenerator
@@ -358,3 +368,83 @@ headBucket bucket = headBucketEx `catches`
                                    , riBucket = Just bucket
                                    }
       return $ NC.responseStatus resp == HT.ok200
+
+-- | Generate a presigned URL. This function allows for advanced usage
+-- - for simple cases prefer the `presigned*URL` functions.
+--
+-- If region is Nothing, it is picked up from the connection
+-- information (no check of bucket existence is performed).
+--
+-- All extra query parameters or headers are signed, and therefore are
+-- required to be sent when the generated URL is actually used.
+makePresignedURL :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object
+                 -> Maybe Region -> HT.Query -> HT.RequestHeaders
+                 -> Minio ByteString
+makePresignedURL expiry method bucket object region extraQuery extraHeaders = do
+  when (expiry > 7*24*3600 || expiry < 0) $
+    throwM $ MErrVInvalidUrlExpiry expiry
+
+
+  ci <- asks mcConnInfo
+
+  let
+    host = formatBS "{}:{}" (connectHost ci, connectPort ci)
+    hostHeader = (hHost, host)
+    ri = def { riMethod = method
+             , riBucket = bucket
+             , riObject = object
+             , riQueryParams = extraQuery
+             , riHeaders = hostHeader : extraHeaders
+             , riRegion = Just $ maybe (connectRegion ci) identity region
+             }
+
+  signPairs <- liftIO $ signV4 ci ri (Just expiry)
+
+  let
+    qpToAdd = (fmap . fmap) Just signPairs
+    queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd)
+    scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
+
+  return $ toS $ toLazyByteString $
+    scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr
+
+-- | Generate a URL with authentication signature to PUT (upload) an
+-- object. Any extra headers if passed, are signed, and so they are
+-- required when the URL is used to upload data. This could be used,
+-- for example, to set user-metadata on the object.
+--
+-- For a list of possible headers to pass, please refer to the PUT
+-- object REST API AWS S3 documentation.
+presignedPutObjectURL :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders
+                      -> Minio ByteString
+presignedPutObjectURL bucket object expirySeconds extraHeaders =
+  makePresignedURL expirySeconds HT.methodPut
+  (Just bucket) (Just object) Nothing [] extraHeaders
+
+-- | Generate a URL with authentication signature to GET (download) an
+-- object. All extra query parameters and headers passed here will be
+-- signed and are required when the generated URL is used. Query
+-- parameters could be used to change the response headers sent by the
+-- server. Headers can be used to set Etag match conditions among
+-- others.
+--
+-- For a list of possible request parameters and headers, please refer
+-- to the GET object REST API AWS S3 documentation.
+presignedGetObjectURL :: Bucket -> Object -> UrlExpiry -> HT.Query
+                      -> HT.RequestHeaders -> Minio ByteString
+presignedGetObjectURL bucket object expirySeconds extraQuery extraHeaders =
+  makePresignedURL expirySeconds HT.methodGet
+  (Just bucket) (Just object) Nothing extraQuery extraHeaders
+
+-- | Generate a URL with authentication signature to make a HEAD
+-- request on an object. This is used to fetch metadata about an
+-- object. All extra headers passed here will be signed and are
+-- required when the generated URL is used.
+--
+-- For a list of possible headers to pass, please refer to the HEAD
+-- object REST API AWS S3 documentation.
+presignedHeadObjectURL :: Bucket -> Object -> UrlExpiry
+                       -> HT.RequestHeaders -> Minio ByteString
+presignedHeadObjectURL bucket object expirySeconds extraHeaders =
+  makePresignedURL expirySeconds HT.methodHead
+  (Just bucket) (Just object) Nothing [] extraHeaders