From abdc9fe320ce0f7d7c8ef121b80004492beb8cd2 Mon Sep 17 00:00:00 2001 From: Krishnan Parthasarathi Date: Sat, 25 Feb 2017 16:42:23 +0530 Subject: [PATCH] Use bucket region cache to minimize getLocation requests (#3) --- examples/listBuckets.hs | 24 ++++++++ examples/makebucket.hs | 24 ++++++++ examples/removebucket.hs | 23 +++++++ src/Network/Minio.hs | 12 ++++ src/Network/Minio/API.hs | 54 +++++++++++++++-- src/Network/Minio/Data.hs | 91 +++++++++++++++++++++++++--- src/Network/Minio/S3API.hs | 13 ++-- src/Network/Minio/Sign/V4.hs | 12 ++-- src/Network/Minio/XmlParser.hs | 5 +- test/LiveServer.hs | 2 +- test/Network/Minio/XmlParser/Test.hs | 2 +- 11 files changed, 231 insertions(+), 31 deletions(-) create mode 100755 examples/listBuckets.hs create mode 100755 examples/makebucket.hs create mode 100755 examples/removebucket.hs diff --git a/examples/listBuckets.hs b/examples/listBuckets.hs new file mode 100755 index 0000000..d3b67b1 --- /dev/null +++ b/examples/listBuckets.hs @@ -0,0 +1,24 @@ +#!/usr/bin/env stack +-- stack --resolver lts-6.27 runghc --package minio-hs + + +{-# Language OverloadedStrings #-} +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +-- This example list buckets that belongs to the user and returns +-- region of the first bucket returned. +main :: IO () +main = do + firstRegionE <- runResourceT $ runMinio minioPlayCI $ do + buckets <- getService + getLocation $ biName $ head buckets + print firstRegionE diff --git a/examples/makebucket.hs b/examples/makebucket.hs new file mode 100755 index 0000000..571c966 --- /dev/null +++ b/examples/makebucket.hs @@ -0,0 +1,24 @@ +#!/usr/bin/env stack +-- stack --resolver lts-6.27 runghc --package minio-hs + + +{-# Language OverloadedStrings #-} +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + res <- runResourceT $ runMinio minioPlayCI $ do + -- N B the region provided for makeBucket is optional. + makeBucket bucket (Just "us-east-1") + print res diff --git a/examples/removebucket.hs b/examples/removebucket.hs new file mode 100755 index 0000000..a6dfed2 --- /dev/null +++ b/examples/removebucket.hs @@ -0,0 +1,23 @@ +#!/usr/bin/env stack +-- stack --resolver lts-6.27 runghc --package minio-hs + + +{-# Language OverloadedStrings #-} +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "my-bucket" + res <- runResourceT $ runMinio minioPlayCI $ do + removeBucket bucket + print res diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 0bf3bdc..6cacd77 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -3,7 +3,11 @@ module Network.Minio ConnectInfo(..) , awsCI + , awsWithRegion , minioPlayCI + , minioSimple + , minioSimpleTLS + , minioWithOpts , Minio , runMinio @@ -34,6 +38,7 @@ module Network.Minio , getService , getLocation , makeBucket + , removeBucket , listObjects , listIncompleteUploads @@ -58,6 +63,7 @@ This module exports the high-level Minio API for object storage. import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB +import qualified Data.Map as Map import Lib.Prelude @@ -108,7 +114,13 @@ makeBucket :: Bucket -> Maybe Region -> Minio () makeBucket bucket regionMay= do region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay putBucket bucket region + modify (Map.insert bucket region) -- | Get an object's metadata from the object store. statObject :: Bucket -> Object -> Minio ObjectInfo statObject bucket object = headObject bucket object + +removeBucket :: Bucket -> Minio() +removeBucket bucket = do + deleteBucket bucket + modify (Map.delete bucket) diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 240d51a..5f04643 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -5,10 +5,13 @@ module Network.Minio.API , runMinio , executeRequest , mkStreamRequest + , getLocation ) where import qualified Data.Conduit as C import Data.Conduit.Binary (sourceHandleRange) +import Data.Default (def) +import qualified Data.Map as Map import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT @@ -19,6 +22,7 @@ import Network.Minio.Data import Network.Minio.Data.Crypto import Network.Minio.Sign.V4 import Network.Minio.Utils +import Network.Minio.XmlParser sha256Header :: ByteString -> HT.Header sha256Header = ("x-amz-content-sha256", ) @@ -38,17 +42,59 @@ getRequestBody (PayloadH h off size) = (return . fromIntegral $ off) (return . fromIntegral $ size) -buildRequest :: (MonadIO m, MonadReader MinioConn m) - => RequestInfo -> m NC.Request + +-- | Fetch bucket location (region) +getLocation :: Bucket -> Minio Region +getLocation bucket = do + resp <- executeRequest $ def { + riBucket = Just bucket + , riQueryParams = [("location", Nothing)] + , riNeedsLocation = False + } + parseLocation $ NC.responseBody resp + + +-- | Looks for region in RegionMap and updates it using getLocation if +-- absent. +discoverRegion :: RequestInfo -> Minio (Maybe Region) +discoverRegion ri = runMaybeT $ do + bucket <- MaybeT $ return $ riBucket ri + regionMay <- gets (Map.lookup bucket) + maybe (do + l <- lift $ getLocation bucket + modify $ Map.insert bucket l + return l + ) return regionMay + + +buildRequest :: RequestInfo -> Minio NC.Request buildRequest ri = do + {- + If ListBuckets/MakeBucket/GetLocation then use connectRegion ci + Else If discovery off use connectRegion ci + Else { + + // Here discovery is on + Lookup region in regionMap + If present use that + Else getLocation + } + -} + ci <- asks mcConnInfo + region <- if | not $ riNeedsLocation ri -> -- getService/makeBucket/getLocation + -- don't need location + return $ Just $ connectRegion ci + | not $ connectAutoDiscoverRegion ci -> -- if autodiscovery of location is disabled by user + return $ Just $ connectRegion ci + | otherwise -> discoverRegion ri + sha256Hash <- getPayloadSHA256Hash (riPayload ri) let newRi = ri { riPayloadHash = sha256Hash , riHeaders = sha256Header sha256Hash : (riHeaders ri) + , riRegion = region } - ci <- asks mcConnInfo - reqHeaders <- liftIO $ signV4 ci newRi return NC.defaultRequest { diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 31c33d9..75210cc 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -5,19 +5,43 @@ import Control.Monad.Base import qualified Control.Monad.Catch as MC import Control.Monad.Trans.Control import Control.Monad.Trans.Resource + import qualified Data.ByteString as B import Data.Default (Default(..)) +import qualified Data.Map as Map import qualified Data.Text as T import Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Conduit as NC import Network.HTTP.Types (Method, Header, Query) import qualified Network.HTTP.Types as HT +import Network.Minio.Errors +import Network.Minio.Utils import Text.XML import Lib.Prelude -import Network.Minio.Errors -import Network.Minio.Utils + +-- TODO: Add a type which provides typed constants for region. this +-- type should have a IsString instance to infer the appropriate +-- constant. +-- | awsRegionMap - library constant +awsRegionMap :: Map.Map Text Text +awsRegionMap = Map.fromList [ + ("us-east-1", "s3.amazonaws.com") + , ("us-east-2", "s3-us-east-2.amazonaws.com") + , ("us-west-1", "s3-us-west-1.amazonaws.com") + , ("us-east-2", "s3-us-west-2.amazonaws.com") + , ("ca-central-1", "s3-ca-central-1.amazonaws.com") + , ("ap-south-1", "s3-ap-south-1.amazonaws.com") + , ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com") + , ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com") + , ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com") + , ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com") + , ("eu-west-1", "s3-eu-west-1.amazonaws.com") + , ("eu-west-2", "s3-eu-west-2.amazonaws.com") + , ("eu-central-1", "s3-eu-central-1.amazonaws.com") + , ("sa-east-1", "s3-sa-east-1.amazonaws.com") + ] -- | Connection Info data type. Use the Default instance to create -- connection info for your service. @@ -28,10 +52,11 @@ data ConnectInfo = ConnectInfo { , connectSecretKey :: Text , connectIsSecure :: Bool , connectRegion :: Region + , connectAutoDiscoverRegion :: Bool } deriving (Eq, Show) instance Default ConnectInfo where - def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" + def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True -- | -- Default aws ConnectInfo. Credentials should be supplied before use. @@ -44,6 +69,21 @@ awsCI = def { , connectIsSecure = True } +-- | +-- aws ConnectInfo with the specified region. +-- This is for users who don't want minio-hs discovering region of a +-- bucket if not known. +awsWithRegion :: Region -> Bool -> ConnectInfo +awsWithRegion region autoDiscoverRegion = + let host = maybe "s3.amazonaws.com" identity $ + Map.lookup region awsRegionMap + in awsCI { + connectHost = host + , connectRegion = region + , connectAutoDiscoverRegion = autoDiscoverRegion + } + + -- | -- Default minio play server ConnectInfo. Credentials are already filled. minioPlayCI :: ConnectInfo @@ -55,6 +95,38 @@ minioPlayCI = def { , connectIsSecure = True } +-- | +-- ConnectInfo for minio server over HTTP. +minioSimple :: Text -> Int -> ConnectInfo +minioSimple host port = def { + connectHost = host + , connectPort = port + , connectRegion = "us-east-1" + , connectIsSecure = False + } + +-- | +-- ConnectInfo for minio server over HTTPS. +minioSimpleTLS :: Text -> Int -> ConnectInfo +minioSimpleTLS host port = mSimple { + connectIsSecure = True + } + where + mSimple = minioSimple host port + +-- | +-- ConnectInfo for minio server with no defaults. +-- This is for users who don't want minio-hs discovering region of a +-- bucket if not known. +minioWithOpts :: Text -> Int -> Region -> Bool -> Bool -> ConnectInfo +minioWithOpts host port region secure autoDiscoverRegion = def { + connectHost = host + , connectPort = port + , connectRegion = region + , connectIsSecure = secure + , connectAutoDiscoverRegion = autoDiscoverRegion + } + -- | -- Represents a bucket in the object store type Bucket = Text @@ -204,10 +276,11 @@ data RequestInfo = RequestInfo { , riPayload :: Payload , riPayloadHash :: ByteString , riRegion :: Maybe Region + , riNeedsLocation :: Bool } instance Default RequestInfo where - def = RequestInfo HT.methodGet def def def def def "" def + def = RequestInfo HT.methodGet def def def def def "" def True getPathFromRI :: RequestInfo -> ByteString getPathFromRI ri = B.concat $ parts @@ -215,11 +288,10 @@ getPathFromRI ri = B.concat $ parts objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri -getRegionFromRI :: RequestInfo -> Text -getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) +type RegionMap = Map.Map Bucket Region newtype Minio a = Minio { - unMinio :: ReaderT MinioConn (ResourceT IO) a + unMinio :: ReaderT MinioConn (StateT RegionMap (ResourceT IO)) a } deriving ( Functor @@ -227,6 +299,7 @@ newtype Minio a = Minio { , Monad , MonadIO , MonadReader MinioConn + , MonadState RegionMap , MonadThrow , MonadCatch , MonadBase IO @@ -234,7 +307,7 @@ newtype Minio a = Minio { ) instance MonadBaseControl IO Minio where - type StM Minio a = a + type StM Minio a = (a, RegionMap) liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio) restoreM = Minio . restoreM @@ -257,7 +330,7 @@ connect ci = do runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) runMinio ci m = do conn <- liftIO $ connect ci - flip runReaderT conn . unMinio $ + flip evalStateT Map.empty . flip runReaderT conn . unMinio $ (m >>= (return . Right)) `MC.catches` [MC.Handler handlerME, MC.Handler handlerHE, MC.Handler handlerFE] where diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index dd9e576..89e159c 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -66,17 +66,11 @@ import Network.Minio.XmlParser -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do - resp <- executeRequest $ def + resp <- executeRequest $ def { + riNeedsLocation = False + } parseListBuckets $ NC.responseBody resp --- | Fetch bucket location (region) -getLocation :: Bucket -> Minio Region -getLocation bucket = do - resp <- executeRequest $ def { riBucket = Just bucket - , riQueryParams = [("location", Nothing)] - } - parseLocation $ NC.responseBody resp - -- | GET an object from the service and return the response headers -- and a conduit source for the object content getObject' :: Bucket -> Object -> HT.Query -> [HT.Header] @@ -98,6 +92,7 @@ putBucket bucket location = do def { riMethod = HT.methodPut , riBucket = Just bucket , riPayload = PayloadBS $ mkCreateBucketConfig location + , riNeedsLocation = False } -- | Single PUT object size. diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 3b2df3e..eb03fa3 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -88,7 +88,9 @@ signV4AtTime ts ci ri = authHeader = (mk "Authorization", authHeaderValue) - scope = getScope ts ri + region = maybe (connectRegion ci) identity $ riRegion ri + + scope = getScope ts region authHeaderValue = B.concat [ "AWS4-HMAC-SHA256 Credential=", @@ -105,7 +107,7 @@ signV4AtTime ts ci ri = signingKey = hmacSHA256RawBS "aws4_request" . hmacSHA256RawBS "s3" - . hmacSHA256RawBS (encodeUtf8 $ getRegionFromRI ri) + . hmacSHA256RawBS (encodeUtf8 region) . hmacSHA256RawBS (awsDateFormatBS ts) $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]) @@ -119,10 +121,10 @@ signV4AtTime ts ci ri = canonicalRequest = getCanonicalRequest ri headersToSign -getScope :: UTCTime -> RequestInfo -> ByteString -getScope ts ri = B.intercalate "/" $ [ +getScope :: UTCTime -> Region -> ByteString +getScope ts region = B.intercalate "/" $ [ pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, - encodeUtf8 $ getRegionFromRI ri, "s3", "aws4_request" + encodeUtf8 region, "s3", "aws4_request" ] getHeadersToSign :: [Header] -> [(ByteString, ByteString)] diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index ec698b3..67b989d 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -15,7 +15,7 @@ import qualified Data.Text as T import Data.Text.Read (decimal) import Data.Time import Text.XML -import Text.XML.Cursor +import Text.XML.Cursor hiding (bool) import Lib.Prelude @@ -65,7 +65,8 @@ parseListBuckets xmldata = do parseLocation :: (MonadThrow m) => LByteString -> m Region parseLocation xmldata = do r <- parseRoot xmldata - return $ T.concat $ r $/ content + let region = T.concat $ r $/ content + return $ bool "us-east-1" region $ region /= "" -- | Parse the response XML of an newMultipartUpload call. parseNewMultipartUpload :: (MonadThrow m) diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 380872c..3c963a7 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -83,7 +83,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "getLocation works" region <- getLocation bucket - liftIO $ region == "" @? ("Got unexpected region => " ++ show region) + liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) step "singlepart putObject works" fPutObject bucket "lsb-release" "/etc/lsb-release" diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index a29e918..0bc994e 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -55,7 +55,7 @@ testParseLocation = do , -- 3. Test parsing of a valid, empty location xml. ("", - "" + "us-east-1" ) ]