Use bucket region cache to minimize getLocation requests (#3)

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

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

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

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)

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 {

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

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.

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

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)

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"

test/Network/Minio/XmlParser/Test.hs

@@ -55,7 +55,7 @@ testParseLocation = do
       ,
       -- 3. Test parsing of a valid, empty location xml.
       ("<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"/>",
-       ""
+       "us-east-1"
       )
       ]