diff --git a/minio-hs.cabal b/minio-hs.cabal --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,5 +1,5 @@ name: minio-hs -version: 0.2.1 +version: 0.3.0 synopsis: A Minio client library, compatible with S3 like services. description: minio-hs provides simple APIs to access Minio and Amazon S3 compatible object storage server. For more details, @@ -106,6 +106,7 @@ , Network.Minio.S3API , Network.Minio.Sign.V4 , Network.Minio.Utils + , Network.Minio.API.Test , Network.Minio.XmlGenerator , Network.Minio.XmlGenerator.Test , Network.Minio.XmlParser @@ -190,7 +191,6 @@ , transformers-base , xml-conduit ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - -- ghc-options: -Wall default-language: Haskell2010 default-extensions: FlexibleContexts , FlexibleInstances @@ -215,6 +215,7 @@ , Network.Minio.S3API , Network.Minio.Sign.V4 , Network.Minio.Utils + , Network.Minio.API.Test , Network.Minio.XmlGenerator , Network.Minio.XmlGenerator.Test , Network.Minio.XmlParser diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -25,7 +25,6 @@ , Minio , runMinio - , runResourceT , def -- * Error handling @@ -53,6 +52,7 @@ ---------------------- , listBuckets , getLocation + , bucketExists , makeBucket , removeBucket @@ -76,7 +76,6 @@ 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 Data.Default (def) @@ -133,7 +132,7 @@ -- | Get an object's metadata from the object store. statObject :: Bucket -> Object -> Minio ObjectInfo -statObject bucket object = headObject bucket object +statObject = headObject -- | Creates a new bucket in the object store. The Region can be -- optionally specified. If not specified, it will use the region @@ -149,3 +148,7 @@ removeBucket bucket = do deleteBucket bucket modify (Map.delete bucket) + +-- | Query the object store if a given bucket is present. +bucketExists :: Bucket -> Minio Bool +bucketExists = headBucket diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -22,13 +22,20 @@ , 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,28 +94,26 @@ 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 Nothing -> return $ connectHost ci - Just r -> if "amazonaws.com" `T.isSuffixOf` (connectHost ci) + Just r -> if "amazonaws.com" `T.isSuffixOf` connectHost ci then maybe (throwM $ MErrVRegionNotSupported r) return @@ -118,7 +123,7 @@ sha256Hash <- getPayloadSHA256Hash (riPayload ri) let newRi = ri { riPayloadHash = sha256Hash - , riHeaders = sha256Header sha256Hash : (riHeaders ri) + , riHeaders = sha256Header sha256Hash : riHeaders ri , riRegion = region } newCi = ci { connectHost = regionHost } @@ -149,3 +154,45 @@ 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 diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -233,7 +233,7 @@ } deriving (Show, Eq) data CopyPartSource = CopyPartSource { - cpSource :: Text -- | formatted like "/sourceBucket/sourceObject" + cpSource :: Text -- | formatted like "\/sourceBucket\/sourceObject" , cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten -- bytes of the source -- object @@ -248,12 +248,12 @@ cpsToHeaders :: CopyPartSource -> [HT.Header] cpsToHeaders cps = ("x-amz-copy-source", encodeUtf8 $ cpSource cps) : - (rangeHdr ++ (zip names values)) + rangeHdr ++ zip names values where names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match", "x-amz-copy-source-if-unmodified-since", "x-amz-copy-source-if-modified-since"] - values = concatMap (maybeToList . fmap encodeUtf8 . (cps &)) + values = mapMaybe (fmap encodeUtf8 . (cps &)) [cpSourceIfMatch, cpSourceIfNoneMatch, fmap formatRFC1123 . cpSourceIfUnmodifiedSince, fmap formatRFC1123 . cpSourceIfModifiedSince] @@ -261,8 +261,7 @@ . HT.renderByteRanges . (:[]) . uncurry HT.ByteRangeFromTo - <$> (map (both fromIntegral) $ - maybeToList $ cpSourceRange cps) + <$> map (both fromIntegral) (maybeToList $ cpSourceRange cps) -- | Extract the source bucket and source object name. TODO: validate -- the bucket and object name extracted. @@ -299,7 +298,7 @@ def = RequestInfo HT.methodGet def def def def def "" def True getPathFromRI :: RequestInfo -> ByteString -getPathFromRI ri = B.concat $ parts +getPathFromRI ri = B.concat parts where objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri @@ -343,11 +342,11 @@ return $ MinioConn ci mgr -- | Run the Minio action and return the result or an error. -runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) +runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a) runMinio ci m = do conn <- liftIO $ connect ci - flip evalStateT Map.empty . flip runReaderT conn . unMinio $ - (m >>= (return . Right)) `MC.catches` + runResourceT . flip evalStateT Map.empty . flip runReaderT conn . unMinio $ + fmap Right m `MC.catches` [ MC.Handler handlerServiceErr , MC.Handler handlerHE , MC.Handler handlerFE diff --git a/src/Network/Minio/Data/ByteString.hs b/src/Network/Minio/Data/ByteString.hs --- a/src/Network/Minio/Data/ByteString.hs +++ b/src/Network/Minio/Data/ByteString.hs @@ -25,7 +25,7 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as LB -import Data.Char (isSpace, toUpper) +import Data.Char (isSpace, toUpper, isAsciiUpper, isAsciiLower, isDigit) import qualified Data.Text as T import Numeric (showHex) @@ -40,7 +40,7 @@ instance UriEncodable [Char] where uriEncode encodeSlash payload = LB.toStrict $ BB.toLazyByteString $ mconcat $ - map (flip uriEncodeChar encodeSlash) payload + map (`uriEncodeChar` encodeSlash) payload instance UriEncodable ByteString where -- assumes that uriEncode is passed ASCII encoded strings. @@ -58,9 +58,9 @@ uriEncodeChar '/' True = BB.byteString "%2F" uriEncodeChar '/' False = BB.char7 '/' uriEncodeChar ch _ - | (ch >= 'A' && ch <= 'Z') - || (ch >= 'a' && ch <= 'z') - || (ch >= '0' && ch <= '9') + | isAsciiUpper ch + || isAsciiLower ch + || isDigit ch || (ch == '_') || (ch == '-') || (ch == '.') diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -34,7 +34,9 @@ | MErrVInvalidSrcObjByteRange (Int64, Int64) | MErrVCopyObjSingleNoRangeAccepted | MErrVRegionNotSupported Text - | MErrXmlParse Text + | MErrVXmlParse Text + | MErrVInvalidBucketName Text + | MErrVInvalidObjectName Text deriving (Show, Eq) instance Exception MErrV diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -35,7 +35,7 @@ let delimiter = bool (Just "/") Nothing recurse - res <- lift $ listObjects' bucket prefix nextToken delimiter + res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing CL.sourceList $ lorObjects res when (lorHasMore res) $ loop (lorNextToken res) @@ -53,12 +53,11 @@ delimiter = bool (Just "/") Nothing recurse res <- lift $ listIncompleteUploads' bucket prefix delimiter - nextKeyMarker nextUploadIdMarker + nextKeyMarker nextUploadIdMarker Nothing - aggrSizes <- lift $ forM (lurUploads res) $ \((uKey, uId, _)) -> do + aggrSizes <- lift $ forM (lurUploads res) $ \(uKey, uId, _) -> do partInfos <- listIncompleteParts bucket uKey uId C.$$ CC.sinkList - return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 - $ partInfos + return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos CL.sourceList $ map (\((uKey, uId, uInitTime), size) -> diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -124,7 +124,7 @@ checkUploadNeeded payload n pmap = do (md5hash, pSize) <- case payload of PayloadBS bs -> return (hashMD5 bs, fromIntegral $ B.length bs) - PayloadH h off size -> liftM (, size) $ + PayloadH h off size -> fmap (, size) $ hashMD5FromSource $ sourceHandleRange h (Just $ fromIntegral off) (Just $ fromIntegral size) case Map.lookup n pmap of @@ -266,7 +266,7 @@ copiedParts <- limitedMapConcurrently 10 (\(pn, cps') -> do (etag, _) <- copyObjectPart b o cps' uid pn [] - return $ (pn, etag) + return (pn, etag) ) partSources diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -25,9 +25,11 @@ -- * Listing objects -------------------- - , ListObjectsResult + , ListObjectsResult(..) , listObjects' + -- * Retrieving buckets + , headBucket -- * Retrieving objects ----------------------- , getObject' @@ -52,7 +54,7 @@ , copyObjectPart , completeMultipartUpload , abortMultipartUpload - , ListUploadsResult + , ListUploadsResult(..) , listIncompleteUploads' , ListPartsResult(..) , listIncompleteParts' @@ -64,12 +66,14 @@ ) where +import Control.Monad.Catch (catches, Handler(..)) import qualified Data.Conduit as C import Data.Default (def) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.Status (status404) -import Lib.Prelude +import Lib.Prelude hiding (catches) import Network.Minio.API import Network.Minio.Data @@ -93,7 +97,7 @@ -> Minio ([HT.Header], C.ResumableSource Minio ByteString) getObject' bucket object queryParams headers = do resp <- mkStreamRequest reqInfo - return $ (NC.responseHeaders resp, NC.responseBody resp) + return (NC.responseHeaders resp, NC.responseBody resp) where reqInfo = def { riBucket = Just bucket , riObject = Just object @@ -103,8 +107,8 @@ -- | Creates a bucket via a PUT bucket call. putBucket :: Bucket -> Region -> Minio () -putBucket bucket location = do - void $ executeRequest $ +putBucket bucket location = void $ + executeRequest $ def { riMethod = HT.methodPut , riBucket = Just bucket , riPayload = PayloadBS $ mkCreateBucketConfig location @@ -141,9 +145,9 @@ -- | List objects in a bucket matching prefix up to delimiter, -- starting from nextToken. -listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text +listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int -> Minio ListObjectsResult -listObjects' bucket prefix nextToken delimiter = do +listObjects' bucket prefix nextToken delimiter maxKeys = do resp <- executeRequest $ def { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = mkOptionalParams params @@ -155,20 +159,21 @@ , ("continuation_token", nextToken) , ("prefix", prefix) , ("delimiter", delimiter) + , ("max-keys", show <$> maxKeys) ] -- | DELETE a bucket from the service. deleteBucket :: Bucket -> Minio () -deleteBucket bucket = do - void $ executeRequest $ +deleteBucket bucket = void $ + executeRequest $ def { riMethod = HT.methodDelete , riBucket = Just bucket } -- | DELETE an object from the service. deleteObject :: Bucket -> Object -> Minio () -deleteObject bucket object = do - void $ executeRequest $ +deleteObject bucket object = void $ + executeRequest $ def { riMethod = HT.methodDelete , riBucket = Just bucket , riObject = Just object @@ -263,8 +268,8 @@ -- | Abort a multipart upload. abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio () -abortMultipartUpload bucket object uploadId = do - void $ executeRequest $ def { riMethod = HT.methodDelete +abortMultipartUpload bucket object uploadId = void $ + executeRequest $ def { riMethod = HT.methodDelete , riBucket = Just bucket , riObject = Just object , riQueryParams = mkOptionalParams params @@ -274,8 +279,8 @@ -- | List incomplete multipart uploads. listIncompleteUploads' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text - -> Maybe Text -> Minio ListUploadsResult -listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker = do + -> Maybe Text -> Maybe Int -> Minio ListUploadsResult +listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys = do resp <- executeRequest $ def { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = params @@ -288,6 +293,7 @@ , ("delimiter", delimiter) , ("key-marker", keyMarker) , ("upload-id-marker", uploadIdMarker) + , ("max-uploads", show <$> maxKeys) ] @@ -325,3 +331,30 @@ maybe (throwM MErrVInvalidObjectInfoResponse) return $ ObjectInfo <$> Just object <*> modTime <*> etag <*> size + + + +-- | Query the object store if a given bucket exists. +headBucket :: Bucket -> Minio Bool +headBucket bucket = headBucketEx `catches` + [ Handler handleNoSuchBucket + , Handler handleStatus404 + ] + + where + handleNoSuchBucket :: ServiceErr -> Minio Bool + handleNoSuchBucket e | e == NoSuchBucket = return False + | otherwise = throwM e + + handleStatus404 :: NC.HttpException -> Minio Bool + handleStatus404 e@(NC.HttpExceptionRequest _ (NC.StatusCodeException res _)) = + if NC.responseStatus res == status404 + then return False + else throwM e + handleStatus404 e = throwM e + + headBucketEx = do + resp <- executeRequest $ def { riMethod = HT.methodHead + , riBucket = Just bucket + } + return $ NC.responseStatus resp == HT.ok200 diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -98,10 +98,10 @@ outHeaders = authHeader : headersWithDate timeBS = awsTimeFormatBS ts dateHeader = (mk "X-Amz-Date", timeBS) - hostHeader = (mk "host", encodeUtf8 $ format "{}:{}" $ + hostHeader = (mk "host", encodeUtf8 $ format "{}:{}" [connectHost ci, show $ connectPort ci]) - headersWithDate = dateHeader : hostHeader : (riHeaders ri) + headersWithDate = dateHeader : hostHeader : riHeaders ri authHeader = (mk "Authorization", authHeaderValue) @@ -126,20 +126,20 @@ . hmacSHA256RawBS "s3" . hmacSHA256RawBS (encodeUtf8 region) . hmacSHA256RawBS (awsDateFormatBS ts) - $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]) + $ B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci] - stringToSign = B.intercalate "\n" $ - ["AWS4-HMAC-SHA256", - timeBS, - scope, - hashSHA256 $ canonicalRequest + stringToSign = B.intercalate "\n" + [ "AWS4-HMAC-SHA256" + , timeBS + , scope + , hashSHA256 canonicalRequest ] canonicalRequest = getCanonicalRequest ri headersToSign getScope :: UTCTime -> Region -> ByteString -getScope ts region = B.intercalate "/" $ [ +getScope ts region = B.intercalate "/" [ pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, encodeUtf8 region, "s3", "aws4_request" ] @@ -148,11 +148,10 @@ getHeadersToSign h = sort $ filter (flip Set.notMember ignoredHeaders . fst) $ - map (\(x, y) -> (CI.foldedCase x, stripBS y)) $ - h + map (\(x, y) -> (CI.foldedCase x, stripBS y)) h getCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)] -> ByteString -getCanonicalRequest ri headersForSign = B.intercalate "\n" $ [ +getCanonicalRequest ri headersForSign = B.intercalate "\n" [ riMethod ri, uriEncode False path, canonicalQueryString, @@ -170,7 +169,6 @@ riQueryParams ri canonicalHeaders = B.concat $ - map (\(x, y) -> B.concat [x, ":", y, "\n"]) $ - headersForSign + map (\(x, y) -> B.concat [x, ":", y, "\n"]) headersForSign signedHeaders = B.intercalate ";" $ map fst headersForSign diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -117,7 +117,7 @@ => NC.Request -> NC.Manager -> m (NC.Response LByteString) httpLbs req mgr = do - respE <- liftIO $ tryHttpEx $ (NC.httpLbs req mgr) + respE <- liftIO $ tryHttpEx $ NC.httpLbs req mgr resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ case contentTypeMay resp of @@ -126,11 +126,11 @@ throwM sErr _ -> throwM $ NC.HttpExceptionRequest req $ - NC.StatusCodeException (const () <$> resp) (show resp) + NC.StatusCodeException (void resp) (show resp) return resp where - tryHttpEx :: (IO (NC.Response LByteString)) + tryHttpEx :: IO (NC.Response LByteString) -> IO (Either NC.HttpException (NC.Response LByteString)) tryHttpEx = try contentTypeMay resp = lookupHeader Hdr.hContentType $ @@ -146,18 +146,18 @@ case contentTypeMay resp of Just "application/xml" -> do respBody <- NC.responseBody resp C.$$+- CB.sinkLbs - sErr <- parseErrResponse $ respBody + sErr <- parseErrResponse respBody throwM sErr _ -> do content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp throwM $ NC.HttpExceptionRequest req $ - NC.StatusCodeException (const () <$> resp) $ content + NC.StatusCodeException (void resp) content return resp where - tryHttpEx :: (R.MonadResourceBase m) => (m a) + tryHttpEx :: (R.MonadResourceBase m) => m a -> m (Either NC.HttpException a) tryHttpEx = ExL.try contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp @@ -189,7 +189,7 @@ -- helper function to build query parameters that are optional. -- don't use it with mandatory query params with empty value. mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query -mkOptionalParams params = HT.toQuery $ (uncurry mkQuery) <$> params +mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params chunkBSConduit :: (Monad m, Integral a) => [a] -> C.Conduit ByteString m ByteString @@ -199,9 +199,7 @@ loop n readChunks (size:sizes) = do bsMay <- C.await case bsMay of - Nothing -> if n > 0 - then C.yield $ B.concat readChunks - else return () + Nothing -> when (n > 0) $ C.yield $ B.concat readChunks Just bs -> if n + fromIntegral (B.length bs) >= size then do let (a, b) = B.splitAt (fromIntegral $ size - n) bs chunkBS = B.concat $ readChunks ++ [a] diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -50,12 +50,12 @@ -- | 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 = 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. @@ -76,7 +76,7 @@ timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content times <- mapM parseS3XMLTime timeStrings - return $ map (\(n, t) -> BucketInfo n t) $ zip names times + return $ zipWith BucketInfo names times -- | Parse the response XML of a location request. parseLocation :: (MonadThrow m) => LByteString -> m Region @@ -107,7 +107,7 @@ mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content mtime <- parseS3XMLTime mtimeStr - return $ (T.concat $ r $// s3Elem "ETag" &/ content, mtime) + return (T.concat $ r $// s3Elem "ETag" &/ content, mtime) -- | Parse the response XML of a list objects call. parseListObjectsResponse :: (MonadThrow m) diff --git a/test/LiveServer.hs b/test/LiveServer.hs --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -83,8 +83,10 @@ let b = T.concat [funTestBucketPrefix, T.pack bktSuffix] liftStep = liftIO . step connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL" - ret <- runResourceT $ runMinio connInfo $ do + ret <- runMinio connInfo $ do liftStep $ "Creating bucket for test - " ++ t + foundBucket <- bucketExists b + liftIO $ foundBucket @?= False makeBucket b def minioTest liftStep b deleteBucket b @@ -109,7 +111,7 @@ 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" @@ -239,7 +241,7 @@ fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" step "Simple list" - res <- listObjects' bucket Nothing Nothing Nothing + res <- listObjects' bucket Nothing Nothing Nothing Nothing let expected = sort $ map (T.concat . ("lsb-release":) . (\x -> [x]) . @@ -260,7 +262,7 @@ step "list incomplete multipart uploads" incompleteUploads <- listIncompleteUploads' bucket Nothing Nothing - Nothing Nothing + Nothing Nothing Nothing liftIO $ (length $ lurUploads incompleteUploads) @?= 10 step "cleanup" diff --git a/test/Network/Minio/API/Test.hs b/test/Network/Minio/API/Test.hs new file mode 100644 --- /dev/null +++ b/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 "日本国" + ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,6 +21,7 @@ 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 @@ ] unitTests :: TestTree -unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests] +unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests, + bucketNameValidityTests, + objectNameValidityTests]