Add bucket and object name validation (#45)

minio-hs.cabal

@@ -106,6 +106,7 @@ test-suite minio-hs-live-server-test
                      , Network.Minio.S3API
                      , Network.Minio.Sign.V4
                      , Network.Minio.Utils
+                     , Network.Minio.API.Test
                      , Network.Minio.XmlGenerator
                      , Network.Minio.XmlGenerator.Test
                      , Network.Minio.XmlParser
@@ -215,6 +216,7 @@ test-suite minio-hs-test
                      , Network.Minio.S3API
                      , Network.Minio.Sign.V4
                      , Network.Minio.Utils
+                     , Network.Minio.API.Test
                      , Network.Minio.XmlGenerator
                      , Network.Minio.XmlGenerator.Test
                      , Network.Minio.XmlParser

src/Network/Minio/API.hs

@@ -22,13 +22,20 @@ module Network.Minio.API
   , executeRequest
   , mkStreamRequest
   , getLocation
+
+  , isValidBucketName
+  , checkBucketNameValidity
+  , isValidObjectName
+  , checkObjectNameValidity
   ) where
 
 import qualified Data.Conduit as C
 import           Data.Conduit.Binary (sourceHandleRange)
 import           Data.Default (def)
 import qualified Data.Map as Map
+import qualified Data.Char as C
 import qualified Data.Text as T
+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
@@ -87,23 +94,21 @@ discoverRegion ri = runMaybeT $ do
 
 buildRequest :: RequestInfo -> Minio NC.Request
 buildRequest ri = do
-  {-
-    If ListBuckets/MakeBucket/GetLocation then use connectRegion ci
-    Else If discovery off use connectRegion ci
-    Else {
+  maybe (return ()) checkBucketNameValidity $ riBucket ri
+  maybe (return ()) checkObjectNameValidity $ riObject ri
 
-    // 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
+
+               -- getService/makeBucket/getLocation -- don't need
+               -- location
+  region <- if | not $ riNeedsLocation ri ->
                    return $ Just $ connectRegion ci
-               | not $ connectAutoDiscoverRegion ci -> -- if autodiscovery of location is disabled by user
+
+               -- if autodiscovery of location is disabled by user
+               | not $ connectAutoDiscoverRegion ci ->
                    return $ Just $ connectRegion ci
+
+               -- discover the region for the request
                | otherwise -> discoverRegion ri
 
   regionHost <- case region of
@@ -149,3 +154,45 @@ mkStreamRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
   http req mgr
+
+-- Bucket name validity check according to AWS rules.
+isValidBucketName :: Bucket -> Bool
+isValidBucketName bucket =
+  not (or [ len < 3 || len > 63
+          , or (map labelCheck labels)
+          , or (map labelCharsCheck labels)
+          , isIPCheck
+          ])
+  where
+    len = T.length bucket
+    labels = T.splitOn "." bucket
+
+    -- does label `l` fail basic checks of length and start/end?
+    labelCheck l = T.length l == 0 || T.head l == '-' || T.last l == '-'
+
+    -- does label `l` have non-allowed characters?
+    labelCharsCheck l = isJust $ T.find (\x -> not (C.isAsciiLower x ||
+                                                    x == '-' ||
+                                                    C.isDigit x)) l
+
+    -- does label `l` have non-digit characters?
+    labelNonDigits l = isJust $ T.find (not . C.isDigit) l
+    labelAsNums = map (not . labelNonDigits) labels
+
+    -- check if bucket name looks like an IP
+    isIPCheck = and labelAsNums && length labelAsNums == 4
+
+-- Throws exception iff bucket name is invalid according to AWS rules.
+checkBucketNameValidity :: MonadThrow m => Bucket -> m ()
+checkBucketNameValidity bucket =
+  when (not $ isValidBucketName bucket) $
+  throwM $ MErrVInvalidBucketName bucket
+
+isValidObjectName :: Object -> Bool
+isValidObjectName object =
+  T.length object > 0 && B.length (encodeUtf8 object) <= 1024
+
+checkObjectNameValidity :: MonadThrow m => Object -> m ()
+checkObjectNameValidity object =
+  when (not $ isValidObjectName object) $
+  throwM $ MErrVInvalidObjectName object

src/Network/Minio/Errors.hs

@@ -34,7 +34,9 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
            | MErrVInvalidSrcObjByteRange (Int64, Int64)
            | MErrVCopyObjSingleNoRangeAccepted
            | MErrVRegionNotSupported Text
-           | MErrXmlParse Text
+           | MErrVXmlParse Text
+           | MErrVInvalidBucketName Text
+           | MErrVInvalidObjectName Text
   deriving (Show, Eq)
 
 instance Exception MErrV

src/Network/Minio/XmlParser.hs

@@ -50,12 +50,12 @@ uncurry4 f (a, b, c, d) = f a b c d
 
 -- | Parse time strings from XML
 parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime
-parseS3XMLTime = either (throwM . MErrXmlParse) return
+parseS3XMLTime = either (throwM . MErrVXmlParse) return
                . parseTimeM True defaultTimeLocale s3TimeFormat
                . T.unpack
 
 parseDecimal :: (MonadThrow m, Integral a) => Text -> m a
-parseDecimal numStr = either (throwM . MErrXmlParse . show) return $ fst <$> decimal numStr
+parseDecimal numStr = either (throwM . MErrVXmlParse . show) return $ fst <$> decimal numStr
 
 parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a]
 parseDecimals numStr = forM numStr parseDecimal
@@ -64,7 +64,7 @@ s3Elem :: Text -> Axis
 s3Elem = element . s3Name
 
 parseRoot :: (MonadThrow m) => LByteString -> m Cursor
-parseRoot = either (throwM . MErrXmlParse . show) (return . fromDocument)
+parseRoot = either (throwM . MErrVXmlParse . show) (return . fromDocument)
           . parseLBS def
 
 -- | Parse the response XML of a list buckets call.

test/LiveServer.hs

@@ -111,7 +111,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
       step "makeBucket with an invalid bucket name and check for appropriate exception."
       invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing
       case invalidMBE of
-        Left exn -> liftIO $ exn @?= InvalidBucketName
+        Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"
         _ -> return ()
 
       step "getLocation works"

test/Network/Minio/API/Test.hs

@@ -0,0 +1,50 @@
+--
+-- Minio Haskell SDK, (C) 2017 Minio, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+module Network.Minio.API.Test
+  ( bucketNameValidityTests
+  , objectNameValidityTests
+  ) where
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Lib.Prelude
+
+import Network.Minio.API
+
+assertBool' = assertBool "Test failed!"
+
+bucketNameValidityTests :: TestTree
+bucketNameValidityTests = testGroup "Bucket Name Validity Tests"
+  [ testCase "Too short 1" $ assertBool' $ not $ isValidBucketName ""
+  , testCase "Too short 2" $ assertBool' $ not $ isValidBucketName "ab"
+  , testCase "Too long 1" $ assertBool' $ not $ isValidBucketName "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+  , testCase "Has upper case" $ assertBool' $ not $ isValidBucketName "ABCD"
+  , testCase "Has punctuation" $ assertBool' $ not $ isValidBucketName "abc,2"
+  , testCase "Has hyphen at end" $ assertBool' $ not $ isValidBucketName "abc-"
+  , testCase "Has consecutive dot" $ assertBool' $ not $ isValidBucketName "abck..eedg"
+  , testCase "Looks like IP" $  assertBool' $ not $ isValidBucketName "10.0.0.1"
+  , testCase "Valid bucket name 1" $ assertBool' $ isValidBucketName "abcd.pqeq.rea"
+  , testCase "Valid bucket name 2" $ assertBool' $ isValidBucketName "abcdedgh1d"
+  , testCase "Valid bucket name 3" $ assertBool' $ isValidBucketName "abc-de-dg-h1d"
+  ]
+
+objectNameValidityTests :: TestTree
+objectNameValidityTests = testGroup "Object Name Validity Tests"
+  [ testCase "Empty name" $ assertBool' $ not $ isValidObjectName ""
+  , testCase "Has unicode characters" $ assertBool' $ isValidObjectName "日本国"
+  ]

test/Spec.hs

@@ -21,6 +21,7 @@ import qualified Data.List as L
 
 import           Lib.Prelude
 
+import           Network.Minio.API.Test
 import           Network.Minio.PutObject
 import           Network.Minio.XmlGenerator.Test
 import           Network.Minio.XmlParser.Test
@@ -110,4 +111,6 @@ qcProps = testGroup "(checked by QuickCheck)"
   ]
 
 unitTests :: TestTree
-unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests]
+unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests,
+                                    bucketNameValidityTests,
+                                    objectNameValidityTests]