From ca3276cd87cc7da39a4809efdeb8b6df0f9e342f Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 13 Jan 2017 11:09:02 +0530 Subject: [PATCH] Basic putObject is working: - This is single PUT action - so only files up to 5GB. - Buffers in memory because chunked singature is not yet implemented. - fPutObject is simply wired to putObject (so does not yet work for multipart uploads --- minio-hs.cabal | 4 ++++ src/Network/Minio.hs | 20 +++++++++++++++++-- src/Network/Minio/API.hs | 22 ++++++++++++++++----- src/Network/Minio/Data.hs | 14 +++++++++++-- src/Network/Minio/Data/Crypto.hs | 16 +++++++++++++-- src/Network/Minio/S3API.hs | 34 +++++++++++++++++++++++++------- test/Spec.hs | 18 +++++++++++++++++ 7 files changed, 110 insertions(+), 18 deletions(-) diff --git a/minio-hs.cabal b/minio-hs.cabal index 36179e5..523eb73 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -36,6 +36,7 @@ library , conduit-extra , containers , cryptonite + , cryptonite-conduit , errors , filepath , http-client @@ -55,6 +56,7 @@ library , NoImplicitPrelude , MultiParamTypeClasses , MultiWayIf + , RankNTypes executable minio-hs-exe hs-source-dirs: app @@ -84,6 +86,7 @@ test-suite minio-hs-test , conduit-extra , containers , cryptonite + , cryptonite-conduit , errors , filepath , http-client @@ -108,6 +111,7 @@ test-suite minio-hs-test , NoImplicitPrelude , MultiParamTypeClasses , MultiWayIf + , RankNTypes other-modules: Lib.Prelude , Network.Minio , Network.Minio.API diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 9bf570f..6122d9c 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -1,6 +1,7 @@ module Network.Minio ( module Exports , fGetObject + , fPutObject ) where {- @@ -21,11 +22,13 @@ import Network.Minio.Data as , ConnectInfo(..) ) -import System.FilePath +import System.FilePath (FilePath) +import qualified System.IO as IO import qualified Data.Conduit as C +import qualified Control.Monad.Trans.Resource as R import qualified Data.Conduit.Binary as CB --- import Lib.Prelude +import Lib.Prelude import Network.Minio.Data import Network.Minio.S3API @@ -34,3 +37,16 @@ fGetObject :: Bucket -> Object -> FilePath -> Minio () fGetObject bucket object fp = do (_, src) <- getObject bucket object [] [] src C.$$+- CB.sinkFileCautious fp + +fPutObject :: Bucket -> Object -> FilePath -> Minio () +fPutObject bucket object fp = do + -- allocate file handle and register cleanup action + (releaseKey, h) <- R.allocate + (IO.openBinaryFile fp IO.ReadMode) + IO.hClose + + size <- liftIO $ IO.hFileSize h + putObject bucket object [] 0 (fromIntegral size) h + + -- release file handle + R.release releaseKey diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index acfdc44..5f32c99 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -14,10 +14,11 @@ import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import Network.HTTP.Types (Method, Header, Query) import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit as C +import Data.Conduit.Binary (sourceHandleRange) import Lib.Prelude -import qualified Data.Conduit as C import Network.Minio.Data import Network.Minio.Data.Crypto @@ -35,12 +36,23 @@ import Network.Minio.Sign.V4 -- -- print $ NC.requestBody r -- NC.httpLbs r mgr +payloadBodyWithHash :: (MonadIO m) => RequestInfo + -> m (ByteString, NC.RequestBody) +payloadBodyWithHash ri = case riPayload ri of + EPayload -> return (hashSHA256 "", NC.RequestBodyBS "") + PayloadBS bs -> return (hashSHA256 bs, NC.RequestBodyBS bs) + PayloadH h off size -> do + let offM = return . fromIntegral $ off + sizeM = return . fromIntegral $ size + hash <- hashSHA256FromSource $ sourceHandleRange h offM sizeM + return (hash, NC.requestBodySource (fromIntegral size) $ + sourceHandleRange h offM sizeM) + buildRequest :: (MonadIO m, MonadReader MinioConn m) => RequestInfo -> m NC.Request buildRequest ri = do - let pload = maybe "" identity $ riPayload ri - phash = hashSHA256 pload - newRi = ri { + (phash, rbody) <- payloadBodyWithHash ri + let newRi = ri { riPayloadHash = phash , riHeaders = ("x-amz-content-sha256", phash) : (riHeaders ri) } @@ -57,7 +69,7 @@ buildRequest ri = do , NC.path = getPathFromRI ri , NC.queryString = HT.renderQuery False $ riQueryParams ri , NC.requestHeaders = reqHeaders - , NC.requestBody = NC.RequestBodyBS pload + , NC.requestBody = rbody } isFailureStatus :: Response body -> Bool diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index acad056..d51c0f0 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -11,10 +11,11 @@ module Network.Minio.Data , getRegionFromRI , Minio , MinioErr(..) + , MErrV(..) , runMinio , defaultConnectInfo , connect - , Payload + , Payload(..) , s3Name ) where @@ -53,7 +54,12 @@ data BucketInfo = BucketInfo { , biCreationDate :: UTCTime } deriving (Show, Eq) -type Payload = Maybe ByteString + +data Payload = EPayload + | PayloadBS ByteString + | PayloadH Handle + Int64 -- offset + Int64 -- size data RequestInfo = RequestInfo { riMethod :: Method @@ -76,10 +82,14 @@ getPathFromRI ri = B.concat $ parts getRegionFromRI :: RequestInfo -> Text getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) +data MErrV = MErrVSinglePUTSizeExceeded Int64 + deriving (Show) + data MinioErr = MErrMsg ByteString -- generic | MErrHttp HttpException -- http exceptions | MErrXml ByteString -- XML parsing/generation errors | MErrService ByteString -- error response from service + | MErrValidation MErrV -- client-side validation errors deriving (Show) newtype Minio a = Minio { diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs index 21e2b21..c7a9f19 100644 --- a/src/Network/Minio/Data/Crypto.hs +++ b/src/Network/Minio/Data/Crypto.hs @@ -1,21 +1,33 @@ module Network.Minio.Data.Crypto ( hashSHA256 + , hashSHA256FromSource , hmacSHA256 , hmacSHA256RawBS , digestToBS , digestToBase16 ) where -import Crypto.Hash (SHA256(..), hashWith) +import Crypto.Hash (SHA256(..), hashWith, Digest) import Crypto.MAC.HMAC (hmac, HMAC) import Data.ByteArray (ByteArrayAccess, convert) import Data.ByteArray.Encoding (convertToBase, Base(Base16)) +import qualified Data.Conduit as C +import Crypto.Hash.Conduit (sinkHash) import Lib.Prelude hashSHA256 :: ByteString -> ByteString -hashSHA256 = convertToBase Base16 . hashWith SHA256 +hashSHA256 = digestToBase16 . hashWith SHA256 + +hashSHA256FromSource :: Monad m => C.Producer m ByteString -> m ByteString +hashSHA256FromSource src = do + digest <- src C.$$ sinkSHA256Hash + return $ digestToBase16 digest + where + -- To help with type inference + sinkSHA256Hash :: Monad m => C.Consumer ByteString m (Digest SHA256) + sinkSHA256Hash = sinkHash hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256 hmacSHA256 message key = hmac key message diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 244049d..d39345f 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -3,6 +3,7 @@ module Network.Minio.S3API , getLocation , getObject , putBucket + , putObject , deleteBucket , deleteObject ) where @@ -10,26 +11,29 @@ module Network.Minio.S3API import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Conduit as NC import qualified Data.Conduit as C +-- import Control.Monad.Trans.Resource (MonadResource) +-- import Data.Conduit.Binary (sinkLbs, sourceHandleRange) +-- import qualified Data.ByteString.Lazy as LB import Lib.Prelude - import Network.Minio.Data import Network.Minio.API import Network.Minio.XmlParser import Network.Minio.XmlGenerator + getService :: Minio [BucketInfo] getService = do resp <- executeRequest $ - requestInfo HT.methodGet Nothing Nothing [] [] Nothing + requestInfo HT.methodGet Nothing Nothing [] [] EPayload parseListBuckets $ NC.responseBody resp getLocation :: Bucket -> Minio Text getLocation bucket = do resp <- executeRequest $ requestInfo HT.methodGet (Just bucket) Nothing [("location", Nothing)] [] - Nothing + EPayload parseLocation $ NC.responseBody resp getObject :: Bucket -> Object -> HT.Query -> [HT.Header] @@ -39,20 +43,36 @@ getObject bucket object queryParams headers = do return $ (NC.responseHeaders resp, NC.responseBody resp) where reqInfo = requestInfo HT.methodGet (Just bucket) (Just object) - queryParams headers Nothing + queryParams headers EPayload putBucket :: Bucket -> Location -> Minio () putBucket bucket location = do void $ executeRequest $ requestInfo HT.methodPut (Just bucket) Nothing [] [] $ - Just $ mkCreateBucketConfig location + PayloadBS $ mkCreateBucketConfig location + +maxSinglePutObjectSizeBytes :: Int64 +maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024 + +putObject :: Bucket -> Object -> [HT.Header] -> Int64 + -> Int64 -> Handle -> Minio () +putObject bucket object headers offset size h = do + -- check length is within single PUT object size. + when (size > maxSinglePutObjectSizeBytes) $ + throwError $ MErrValidation $ MErrVSinglePUTSizeExceeded size + + -- content-length header is automatically set by library. + void $ executeRequest $ + requestInfo HT.methodPut (Just bucket) (Just object) [] headers $ + PayloadH h offset size + deleteBucket :: Bucket -> Minio () deleteBucket bucket = do void $ executeRequest $ - requestInfo HT.methodDelete (Just bucket) Nothing [] [] Nothing + requestInfo HT.methodDelete (Just bucket) Nothing [] [] EPayload deleteObject :: Bucket -> Object -> Minio () deleteObject bucket object = do void $ executeRequest $ - requestInfo HT.methodDelete (Just bucket) (Just object) [] [] Nothing + requestInfo HT.methodDelete (Just bucket) (Just object) [] [] EPayload diff --git a/test/Spec.hs b/test/Spec.hs index e76ea73..22f5f36 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,9 +3,15 @@ import Protolude import Test.Tasty import Test.Tasty.HUnit +-- import qualified System.IO as SIO + import Control.Monad.Trans.Resource (runResourceT) +-- import qualified Conduit as C +-- import Data.Conduit.Binary + import Network.Minio +-- import Network.Minio.S3API import XmlTests main :: IO () @@ -50,6 +56,18 @@ unitTests = testGroup "Unit tests" step "Running test.." ret <- runResourceT $ runMinio mc $ getService isRight ret @? ("getService failure => " ++ show ret) + , testCaseSteps "Simple putObject works" $ \step -> do + step "Preparing..." + + mc <- connect defaultConnectInfo + + step "Running test.." + ret <- runResourceT $ runMinio mc $ + fPutObject "testbucket" "lsb-release" "/etc/lsb-release" + -- h <- SIO.openBinaryFile "/etc/lsb-release" SIO.ReadMode + -- ret <- runResourceT $ runMinio mc $ + -- putObject "testbucket" "lsb-release" [] 0 105 h + isRight ret @? ("putObject failure => " ++ show ret) , testCase "Test mkCreateBucketConfig." testMkCreateBucketConfig ]