diff --git a/minio-hs.cabal b/minio-hs.cabal index f75460f..1aa410d 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -57,11 +57,12 @@ library , containers >= 0.5 , cryptonite >= 0.25 , cryptonite-conduit >= 0.2 - , data-default >= 0.7 + , directory , filepath >= 1.4 , http-client >= 0.5 , http-conduit >= 2.3 , http-types >= 0.12 + , ini , memory >= 0.14 , resourcet >= 1.2 , text >= 1.2 @@ -142,12 +143,12 @@ test-suite minio-hs-live-server-test , containers , cryptonite , cryptonite-conduit - , data-default , directory , filepath , http-client , http-conduit , http-types + , ini , memory , QuickCheck , resourcet @@ -181,11 +182,12 @@ test-suite minio-hs-test , containers , cryptonite , cryptonite-conduit - , data-default + , filepath , directory , http-client , http-conduit , http-types + , ini , memory , QuickCheck , resourcet diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 4b8ecba..d79c11d 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -18,18 +18,27 @@ module Network.Minio ( + -- * Credentials + Credentials (..) + , fromAWSConfigFile + , fromAWSEnv + , fromMinioEnv -- * Connecting to object storage --------------------------------- - ConnectInfo(..) - , awsCI - , gcsCI + , ConnectInfo + , setRegion + , setCreds + , setCredsFrom + , MinioConn + , mkMinioConn -- ** Connection helpers ------------------------ - , awsWithRegionCI , minioPlayCI - , minioCI + , awsCI + , gcsCI + -- * Minio Monad ---------------- @@ -39,8 +48,9 @@ module Network.Minio -- this Monad. , Minio + , runMinioWith , runMinio - , def + -- * Bucket Operations ---------------------- @@ -76,12 +86,16 @@ module Network.Minio -- ** Bucket Notifications , Notification(..) + , defaultNotification , NotificationConfig(..) , Arn , Event(..) , Filter(..) + , defaultFilter , FilterKey(..) + , defaultFilterKey , FilterRules(..) + , defaultFilterRules , FilterRule(..) , getBucketNotification , putBucketNotification @@ -99,6 +113,7 @@ module Network.Minio , putObject -- | Input data type represents PutObject options. , PutObjectOptions + , defaultPutObjectOptions , pooContentType , pooContentEncoding , pooContentDisposition @@ -111,6 +126,7 @@ module Network.Minio , getObject -- | Input data type represents GetObject options. , GetObjectOptions + , defaultGetObjectOptions , gooRange , gooIfMatch , gooIfNoneMatch @@ -120,6 +136,7 @@ module Network.Minio -- ** Server-side copying , copyObject , SourceInfo + , defaultSourceInfo , srcBucket , srcObject , srcRange @@ -128,6 +145,7 @@ module Network.Minio , srcIfModifiedSince , srcIfUnmodifiedSince , DestinationInfo + , defaultDestinationInfo , dstBucket , dstObject @@ -178,7 +196,6 @@ This module exports the high-level Minio API for object storage. import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC -import Data.Default (def) import Lib.Prelude diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 18e3a30..ff8540e 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -31,7 +31,6 @@ module Network.Minio.API import qualified Data.ByteString as B import qualified Data.Char as C import qualified Data.Conduit as C -import Data.Default (def) import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Time.Clock as Time @@ -53,7 +52,7 @@ import Network.Minio.XmlParser -- | Fetch bucket location (region) getLocation :: Bucket -> Minio Region getLocation bucket = do - resp <- executeRequest $ def { + resp <- executeRequest $ defaultS3ReqInfo { riBucket = Just bucket , riQueryParams = [("location", Nothing)] , riNeedsLocation = False diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs index 66d0e93..664ed49 100644 --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -16,7 +16,6 @@ module Network.Minio.CopyObject where -import Data.Default (def) import qualified Data.List as List import Lib.Prelude @@ -81,7 +80,7 @@ multiPartCopyObject b o cps srcSize = do partRanges = selectCopyRanges byteRange partSources = map (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end) })) partRanges - dstInfo = def { dstBucket = b, dstObject = o} + dstInfo = defaultDestinationInfo { dstBucket = b, dstObject = o} copiedParts <- limitedMapConcurrently 10 (\(pn, cps') -> do diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index c334627..d48d6e2 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -25,9 +25,11 @@ import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..), import Control.Monad.Trans.Resource import qualified Data.ByteString as B import Data.CaseInsensitive (mk) -import Data.Default (Default (..)) +import qualified Data.Ini as Ini import qualified Data.Map as Map +import Data.String (IsString (..)) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Data.Time (defaultTimeLocale, formatTime) import GHC.Show (Show (show)) import Network.HTTP.Client (defaultManagerSettings) @@ -36,6 +38,9 @@ import Network.HTTP.Types (ByteRange, Header, Method, Query, hRange) import qualified Network.HTTP.Types as HT import Network.Minio.Errors +import System.Directory (doesFileExist, getHomeDirectory) +import qualified System.Environment as Env +import System.FilePath.Posix (combine) import Text.XML import qualified UnliftIO as U @@ -92,11 +97,73 @@ data ConnectInfo = ConnectInfo { } deriving (Eq, Show) --- | Connects to a Minio server located at @localhost:9000@ with access --- key /minio/ and secret key /minio123/. It is over __HTTP__ by --- default. -instance Default ConnectInfo where - def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True +instance IsString ConnectInfo where + fromString str = let req = NC.parseRequest_ str + in ConnectInfo + { connectHost = TE.decodeUtf8 $ NC.host req + , connectPort = NC.port req + , connectAccessKey = "" + , connectSecretKey = "" + , connectIsSecure = NC.secure req + , connectRegion = "" + , connectAutoDiscoverRegion = True + } + +data Credentials = Credentials { cAccessKey :: Text + , cSecretKey :: Text + } deriving (Eq, Show) + +type Provider = IO (Maybe Credentials) + +findFirst :: [Provider] -> Provider +findFirst [] = return Nothing +findFirst (f:fs) = do c <- f + maybe (findFirst fs) (return . Just) c + +fromAWSConfigFile :: Provider +fromAWSConfigFile = do + credsE <- runExceptT $ do + homeDir <- lift $ getHomeDirectory + let awsCredsFile = homeDir `combine` ".aws" `combine` "credentials" + fileExists <- lift $ doesFileExist awsCredsFile + bool (throwE "FileNotFound") (return ()) fileExists + ini <- ExceptT $ Ini.readIniFile awsCredsFile + akey <- ExceptT $ return + $ Ini.lookupValue "default" "aws_access_key_id" ini + skey <- ExceptT $ return + $ Ini.lookupValue "default" "aws_secret_access_key" ini + return $ Credentials akey skey + return $ hush credsE + +fromAWSEnv :: Provider +fromAWSEnv = runMaybeT $ do + akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID" + skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY" + return $ Credentials (T.pack akey) (T.pack skey) + +fromMinioEnv :: Provider +fromMinioEnv = runMaybeT $ do + akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY" + skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY" + return $ Credentials (T.pack akey) (T.pack skey) + +setCredsFrom :: [Provider] -> ConnectInfo -> IO ConnectInfo +setCredsFrom ps ci = do pMay <- findFirst ps + maybe + (throwIO MErrVMissingCredentials) + (return . (flip setCreds ci)) + pMay + +setCreds :: Credentials -> ConnectInfo -> ConnectInfo +setCreds (Credentials accessKey secretKey) connInfo = + connInfo { connectAccessKey = accessKey + , connectSecretKey = secretKey + } + +setRegion :: Region -> ConnectInfo -> ConnectInfo +setRegion r connInfo = connInfo { connectRegion = r + , connectAutoDiscoverRegion = False + } getHostAddr :: ConnectInfo -> ByteString getHostAddr ci = if | port == 80 || port == 443 -> toS host @@ -110,92 +177,25 @@ getHostAddr ci = if | port == 80 || port == 443 -> toS host -- | Default GCS ConnectInfo. Works only for "Simple Migration" -- use-case with interoperability mode enabled on GCP console. For -- more information - https://cloud.google.com/storage/docs/migrating --- Credentials should be supplied before use, for e.g.: --- --- > gcsCI { --- > connectAccessKey = "my-access-key" --- > , connectSecretKey = "my-secret-key" --- > } - +-- Credentials should be supplied before use. gcsCI :: ConnectInfo -gcsCI = def { - connectHost = "storage.googleapis.com" - , connectPort = 443 - , connectRegion = "us" -- picking region with Multi-Regional support - , connectAccessKey = "" - , connectSecretKey = "" - , connectIsSecure = True - , connectAutoDiscoverRegion = True - } +gcsCI = setRegion "us" + "https://storage.googleapis.com" + -- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials --- should be supplied before use, for e.g.: --- --- > awsCI { --- > connectAccessKey = "my-access-key" --- > , connectSecretKey = "my-secret-key" --- > } +-- should be supplied before use. awsCI :: ConnectInfo -awsCI = def { - connectHost = "s3.amazonaws.com" - , connectPort = 443 - , connectAccessKey = "" - , connectSecretKey = "" - , connectIsSecure = True - } - --- | AWS ConnectInfo with a specified region. It can optionally --- disable the automatic discovery of a bucket's region via the --- Boolean argument. --- --- > awsWithRegionCI "us-west-1" False { --- > connectAccessKey = "my-access-key" --- > , connectSecretKey = "my-secret-key" --- > } --- --- This restricts all operations to the "us-west-1" region and does --- not perform any bucket location requests. -awsWithRegionCI :: Region -> Bool -> ConnectInfo -awsWithRegionCI region autoDiscoverRegion = - let host = maybe "s3.amazonaws.com" identity $ - Map.lookup region awsRegionMap - in awsCI { - connectHost = host - , connectRegion = region - , connectAutoDiscoverRegion = autoDiscoverRegion - } +awsCI = "https://s3.amazonaws.com" -- | -- ConnectInfo. Credentials are already filled in. minioPlayCI :: ConnectInfo -minioPlayCI = def { - connectHost = "play.minio.io" - , connectPort = 9000 - , connectAccessKey = "Q3AM3UQ867SPQQA43P2F" - , connectSecretKey = "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" - , connectIsSecure = True - , connectAutoDiscoverRegion = False - } - --- | ConnectInfo for Minio server. Takes hostname, port and a Boolean --- to enable TLS. --- --- > minioCI "minio.example.com" 9000 True { --- > connectAccessKey = "my-access-key" --- > , connectSecretKey = "my-secret-key" --- > } --- --- This connects to a Minio server at the given hostname and port over --- HTTPS. -minioCI :: Text -> Int -> Bool -> ConnectInfo -minioCI host port isSecure = def { - connectHost = host - , connectPort = port - , connectRegion = "us-east-1" - , connectIsSecure = isSecure - , connectAutoDiscoverRegion = False - } +minioPlayCI = let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" + in setCreds playCreds + $ setRegion "us-east-1" + "https://play.minio.io:9000" -- | -- Represents a bucket in the object store @@ -241,8 +241,8 @@ data PutObjectOptions = PutObjectOptions { } deriving (Show, Eq) -- Provide a default instance -instance Default PutObjectOptions where - def = PutObjectOptions def def def def def def [] def +defaultPutObjectOptions :: PutObjectOptions +defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing addXAmzMetaPrefix :: Text -> Text addXAmzMetaPrefix s = do @@ -361,17 +361,17 @@ data SourceInfo = SourceInfo { , srcIfUnmodifiedSince :: Maybe UTCTime } deriving (Show, Eq) -instance Default SourceInfo where - def = SourceInfo "" "" def def def def def +defaultSourceInfo :: SourceInfo +defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing -- | Represents destination object in server-side copy object -data DestinationInfo = DestinationInfo { - dstBucket :: Text - , dstObject :: Text - } deriving (Show, Eq) +data DestinationInfo = DestinationInfo + { dstBucket :: Text + , dstObject :: Text + } deriving (Show, Eq) -instance Default DestinationInfo where - def = DestinationInfo "" "" +defaultDestinationInfo :: DestinationInfo +defaultDestinationInfo = DestinationInfo "" "" data GetObjectOptions = GetObjectOptions { -- | Set object's data of given offset begin and end, @@ -389,8 +389,8 @@ data GetObjectOptions = GetObjectOptions { , gooIfModifiedSince :: Maybe UTCTime } deriving (Show, Eq) -instance Default GetObjectOptions where - def = GetObjectOptions def def def def def +defaultGetObjectOptions :: GetObjectOptions +defaultGetObjectOptions = GetObjectOptions Nothing Nothing Nothing Nothing Nothing gooToHeaders :: GetObjectOptions -> [HT.Header] gooToHeaders goo = rangeHdr ++ zip names values @@ -450,22 +450,23 @@ data Filter = Filter { fFilter :: FilterKey } deriving (Show, Eq) -instance Default Filter where - def = Filter def +defaultFilter :: Filter +defaultFilter = Filter defaultFilterKey data FilterKey = FilterKey { fkKey :: FilterRules } deriving (Show, Eq) -instance Default FilterKey where - def = FilterKey def +defaultFilterKey :: FilterKey +defaultFilterKey = FilterKey defaultFilterRules data FilterRules = FilterRules { frFilterRules :: [FilterRule] } deriving (Show, Eq) -instance Default FilterRules where - def = FilterRules [] +defaultFilterRules :: FilterRules +defaultFilterRules = FilterRules [] + -- | A filter rule that can act based on the suffix or prefix of an -- object. As an example, let's create two filter rules: @@ -504,8 +505,8 @@ data Notification = Notification , nCloudFunctionConfigurations :: [NotificationConfig] } deriving (Eq, Show) -instance Default Notification where - def = Notification [] [] [] +defaultNotification :: Notification +defaultNotification = Notification [] [] [] -- | Represents different kinds of payload that are used with S3 API -- requests. @@ -514,8 +515,8 @@ data Payload = PayloadBS ByteString Int64 -- offset Int64 -- size -instance Default Payload where - def = PayloadBS "" +defaultPayload :: Payload +defaultPayload = PayloadBS "" data AdminReqInfo = AdminReqInfo { ariMethod :: Method @@ -538,8 +539,9 @@ data S3ReqInfo = S3ReqInfo { , riNeedsLocation :: Bool } -instance Default S3ReqInfo where - def = S3ReqInfo HT.methodGet def def def def def Nothing def True +defaultS3ReqInfo :: S3ReqInfo +defaultS3ReqInfo = S3ReqInfo HT.methodGet Nothing Nothing + [] [] defaultPayload Nothing Nothing True getS3Path :: Maybe Bucket -> Maybe Object -> ByteString getS3Path b o = @@ -594,14 +596,11 @@ connect ci = do let settings | connectIsSecure ci = NC.tlsManagerSettings | otherwise = defaultManagerSettings mgr <- NC.newManager settings - rMapMVar <- M.newMVar Map.empty - return $ MinioConn ci mgr rMapMVar + mkMinioConn ci mgr --- | Run the Minio action and return the result or an error. -runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a) -runMinio ci m = do - conn <- liftIO $ connect ci - runResourceT . flip runReaderT conn . unMinio $ + +runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a) +runMinioWith conn m = runResourceT . flip runReaderT conn . unMinio $ fmap Right m `U.catches` [ U.Handler handlerServiceErr , U.Handler handlerHE @@ -614,6 +613,17 @@ runMinio ci m = do handlerFE = return . Left . MErrIO handlerValidation = return . Left . MErrValidation +mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn +mkMinioConn ci mgr = do + rMapMVar <- M.newMVar Map.empty + return $ MinioConn ci mgr rMapMVar + +-- | Run the Minio action and return the result or an error. +runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a) +runMinio ci m = do + conn <- connect ci + runMinioWith conn m + s3Name :: Text -> Text -> Name s3Name ns s = Name s (Just ns) Nothing diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs index 5f9d3b6..079a851 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -40,6 +40,7 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64 | MErrVInvalidUrlExpiry Int | MErrVJsonParse Text | MErrVInvalidHealPath + | MErrVMissingCredentials deriving (Show, Eq) instance Exception MErrV diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index b7f3190..0fa1688 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -92,7 +92,6 @@ module Network.Minio.S3API import qualified Data.ByteString as BS import qualified Data.Conduit as C -import Data.Default (def) import qualified Data.Text as T import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT @@ -112,7 +111,7 @@ import Network.Minio.XmlParser -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do - resp <- executeRequest $ def { + resp <- executeRequest $ defaultS3ReqInfo { riNeedsLocation = False } parseListBuckets $ NC.responseBody resp @@ -125,7 +124,7 @@ getObject' bucket object queryParams headers = do resp <- mkStreamRequest reqInfo return (NC.responseHeaders resp, NC.responseBody resp) where - reqInfo = def { riBucket = Just bucket + reqInfo = defaultS3ReqInfo { riBucket = Just bucket , riObject = Just object , riQueryParams = queryParams , riHeaders = headers @@ -136,7 +135,7 @@ putBucket :: Bucket -> Region -> Minio () putBucket bucket location = do ns <- asks getSvcNamespace void $ executeRequest $ - def { riMethod = HT.methodPut + defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riPayload = PayloadBS $ mkCreateBucketConfig ns location , riNeedsLocation = False @@ -155,7 +154,7 @@ putObjectSingle' bucket object headers bs = do -- content-length header is automatically set by library. resp <- executeRequest $ - def { riMethod = HT.methodPut + defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riObject = Just object , riHeaders = headers @@ -179,7 +178,7 @@ putObjectSingle bucket object headers h offset size = do -- content-length header is automatically set by library. resp <- executeRequest $ - def { riMethod = HT.methodPut + defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riObject = Just object , riHeaders = headers @@ -197,7 +196,7 @@ putObjectSingle bucket object headers h offset size = do listObjectsV1' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int -> Minio ListObjectsV1Result listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do - resp <- executeRequest $ def { riMethod = HT.methodGet + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = mkOptionalParams params } @@ -215,7 +214,7 @@ listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int -> Minio ListObjectsResult listObjects' bucket prefix nextToken delimiter maxKeys = do - resp <- executeRequest $ def { riMethod = HT.methodGet + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = mkOptionalParams params } @@ -233,7 +232,7 @@ listObjects' bucket prefix nextToken delimiter maxKeys = do deleteBucket :: Bucket -> Minio () deleteBucket bucket = void $ executeRequest $ - def { riMethod = HT.methodDelete + defaultS3ReqInfo { riMethod = HT.methodDelete , riBucket = Just bucket } @@ -241,7 +240,7 @@ deleteBucket bucket = void $ deleteObject :: Bucket -> Object -> Minio () deleteObject bucket object = void $ executeRequest $ - def { riMethod = HT.methodDelete + defaultS3ReqInfo { riMethod = HT.methodDelete , riBucket = Just bucket , riObject = Just object } @@ -249,7 +248,7 @@ deleteObject bucket object = void $ -- | Create a new multipart upload. newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId newMultipartUpload bucket object headers = do - resp <- executeRequest $ def { riMethod = HT.methodPost + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPost , riBucket = Just bucket , riObject = Just object , riQueryParams = [("uploads", Nothing)] @@ -262,7 +261,7 @@ putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header] -> Payload -> Minio PartTuple putObjectPart bucket object uploadId partNumber headers payload = do resp <- executeRequest $ - def { riMethod = HT.methodPut + defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riObject = Just object , riQueryParams = mkOptionalParams params @@ -304,7 +303,7 @@ copyObjectPart :: DestinationInfo -> SourceInfo -> UploadId -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime) copyObjectPart dstInfo srcInfo uploadId partNumber headers = do resp <- executeRequest $ - def { riMethod = HT.methodPut + defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just $ dstBucket dstInfo , riObject = Just $ dstObject dstInfo , riQueryParams = mkOptionalParams params @@ -328,7 +327,7 @@ copyObjectSingle bucket object srcInfo headers = do when (isJust $ srcRange srcInfo) $ throwIO MErrVCopyObjSingleNoRangeAccepted resp <- executeRequest $ - def { riMethod = HT.methodPut + defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riObject = Just object , riHeaders = headers ++ srcInfoToHeaders srcInfo @@ -340,7 +339,7 @@ completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartTuple] -> Minio ETag completeMultipartUpload bucket object uploadId partTuple = do resp <- executeRequest $ - def { riMethod = HT.methodPost + defaultS3ReqInfo { riMethod = HT.methodPost , riBucket = Just bucket , riObject = Just object , riQueryParams = mkOptionalParams params @@ -354,7 +353,7 @@ completeMultipartUpload bucket object uploadId partTuple = do -- | Abort a multipart upload. abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio () abortMultipartUpload bucket object uploadId = void $ - executeRequest $ def { riMethod = HT.methodDelete + executeRequest $ defaultS3ReqInfo { riMethod = HT.methodDelete , riBucket = Just bucket , riObject = Just object , riQueryParams = mkOptionalParams params @@ -366,7 +365,7 @@ abortMultipartUpload bucket object uploadId = void $ listIncompleteUploads' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int -> Minio ListUploadsResult listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys = do - resp <- executeRequest $ def { riMethod = HT.methodGet + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = params } @@ -386,7 +385,7 @@ listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys listIncompleteParts' :: Bucket -> Object -> UploadId -> Maybe Text -> Maybe Text -> Minio ListPartsResult listIncompleteParts' bucket object uploadId maxParts partNumMarker = do - resp <- executeRequest $ def { riMethod = HT.methodGet + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet , riBucket = Just bucket , riObject = Just object , riQueryParams = mkOptionalParams params @@ -403,7 +402,7 @@ listIncompleteParts' bucket object uploadId maxParts partNumMarker = do -- | Get metadata of an object. headObject :: Bucket -> Object -> Minio ObjectInfo headObject bucket object = do - resp <- executeRequest $ def { riMethod = HT.methodHead + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodHead , riBucket = Just bucket , riObject = Just object } @@ -439,7 +438,7 @@ headBucket bucket = headBucketEx `catches` handleStatus404 e = throwIO e headBucketEx = do - resp <- executeRequest $ def { riMethod = HT.methodHead + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodHead , riBucket = Just bucket } return $ NC.responseStatus resp == HT.ok200 @@ -448,7 +447,7 @@ headBucket bucket = headBucketEx `catches` putBucketNotification :: Bucket -> Notification -> Minio () putBucketNotification bucket ncfg = do ns <- asks getSvcNamespace - void $ executeRequest $ def { riMethod = HT.methodPut + void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riQueryParams = [("notification", Nothing)] , riPayload = PayloadBS $ @@ -458,7 +457,7 @@ putBucketNotification bucket ncfg = do -- | Retrieve the notification configuration on a bucket. getBucketNotification :: Bucket -> Minio Notification getBucketNotification bucket = do - resp <- executeRequest $ def { riMethod = HT.methodGet + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = [("notification", Nothing)] } @@ -466,12 +465,12 @@ getBucketNotification bucket = do -- | Remove all notifications configured on a bucket. removeAllBucketNotification :: Bucket -> Minio () -removeAllBucketNotification = flip putBucketNotification def +removeAllBucketNotification = flip putBucketNotification defaultNotification -- | Fetch the policy if any on a bucket. getBucketPolicy :: Bucket -> Minio Text getBucketPolicy bucket = do - resp <- executeRequest $ def { riMethod = HT.methodGet + resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet , riBucket = Just bucket , riQueryParams = [("policy", Nothing)] } @@ -489,7 +488,7 @@ setBucketPolicy bucket policy = do -- | Save a new policy on a bucket. putBucketPolicy :: Bucket -> Text -> Minio() putBucketPolicy bucket policy = do - void $ executeRequest $ def { riMethod = HT.methodPut + void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut , riBucket = Just bucket , riQueryParams = [("policy", Nothing)] , riPayload = PayloadBS $ encodeUtf8 policy @@ -498,7 +497,7 @@ putBucketPolicy bucket policy = do -- | Delete any policy set on a bucket. deleteBucketPolicy :: Bucket -> Minio() deleteBucketPolicy bucket = do - void $ executeRequest $ def { riMethod = HT.methodDelete + void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodDelete , riBucket = Just bucket , riQueryParams = [("policy", Nothing)] } diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 4758187..4c81444 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -43,7 +43,6 @@ import qualified Network.HTTP.Types.Header as H import Lib.Prelude -import Network.Minio.Data import Network.Minio.Data.ByteString import Network.Minio.Data.Crypto import Network.Minio.Data.Time @@ -72,7 +71,7 @@ data SignParams = SignParams { spAccessKey :: Text , spSecretKey :: Text , spTimeStamp :: UTCTime - , spRegion :: Maybe Region + , spRegion :: Maybe Text , spExpirySecs :: Maybe Int , spPayloadHash :: Maybe ByteString } deriving (Show) @@ -174,7 +173,7 @@ signV4 !sp !req = in output -mkScope :: UTCTime -> Region -> ByteString +mkScope :: UTCTime -> Text -> ByteString mkScope ts region = B.intercalate "/" [ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts , toS region @@ -222,7 +221,7 @@ mkStringToSign ts !scope !canonicalRequest = B.intercalate "\n" , hashSHA256 canonicalRequest ] -mkSigningKey :: UTCTime -> Region -> ByteString -> ByteString +mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request" . hmacSHA256RawBS "s3" . hmacSHA256RawBS (toS region) diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 39fc5b9..bca38fd 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- -- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- @@ -26,7 +27,6 @@ import Data.Conduit (yield) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import Data.Conduit.Combinators (sinkList) -import Data.Default (Default (..)) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Time (fromGregorian) @@ -83,12 +83,15 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z')) let b = T.concat [funTestBucketPrefix, T.pack bktSuffix] liftStep = liftIO . step - connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL" + connInfo <- ( bool minioPlayCI + ( setCreds (Credentials "minio" "minio123") "http://localhost:9000" ) + . isJust + ) <$> lookupEnv "MINIO_LOCAL" ret <- runMinio connInfo $ do liftStep $ "Creating bucket for test - " ++ t foundBucket <- bucketExists b liftIO $ foundBucket @?= False - makeBucket b def + makeBucket b Nothing minioTest liftStep b deleteBucket b isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret) @@ -116,7 +119,7 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $ destFile <- mkRandFile 0 step "Retrieve the created object and check size" - fGetObject bucket object destFile def + fGetObject bucket object destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb15) @? "Wrong file size of put file after getting" @@ -135,11 +138,11 @@ putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $ rFile <- mkRandFile mb1 step "Upload single file." - putObject bucket obj (CB.sourceFile rFile) (Just mb1) def + putObject bucket obj (CB.sourceFile rFile) (Just mb1) defaultPutObjectOptions step "Retrieve and verify file size" destFile <- mkRandFile 0 - fGetObject bucket obj destFile def + fGetObject bucket obj destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb1) @? "Wrong file size of put file after getting" @@ -158,11 +161,11 @@ putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no siz rFile <- mkRandFile mb70 step "Upload multipart file." - putObject bucket obj (CB.sourceFile rFile) Nothing def + putObject bucket obj (CB.sourceFile rFile) Nothing defaultPutObjectOptions step "Retrieve and verify file size" destFile <- mkRandFile 0 - fGetObject bucket obj destFile def + fGetObject bucket obj destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb70) @? "Wrong file size of put file after getting" @@ -177,7 +180,7 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $ step "put 3 objects" let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"] forM_ expectedObjects $ - \obj -> fPutObject bucket obj "/etc/lsb-release" def + \obj -> fPutObject bucket obj "/etc/lsb-release" defaultPutObjectOptions step "High-level listing of objects" objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList @@ -241,7 +244,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do let objects = (\s ->T.concat ["lsb-release", T.pack (show s)]) <$> [1..10::Int] forM_ [1..10::Int] $ \s -> - fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" def + fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" defaultPutObjectOptions step "Simple list" res <- listObjects' bucket Nothing Nothing Nothing Nothing @@ -312,11 +315,11 @@ liveServerUnitTests = testGroup "Unit tests against a live server" let mb80 = 80 * 1024 * 1024 obj = "mpart" - void $ putObjectInternal bucket obj def $ ODFile "/dev/zero" (Just mb80) + void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80) step "Retrieve and verify file size" destFile <- mkRandFile 0 - fGetObject bucket obj destFile def + fGetObject bucket obj destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ gotSize == Right (Just mb80) @? "Wrong file size of put file after getting" @@ -356,7 +359,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "create server object with content-type" inputFile <- mkRandFile size1 - fPutObject bucket object inputFile def{ + fPutObject bucket object inputFile defaultPutObjectOptions { pooContentType = Just "application/javascript" } @@ -368,7 +371,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (Map.lookup "Content-Type" m) step "upload object with content-encoding set to identity" - fPutObject bucket object inputFile def { + fPutObject bucket object inputFile defaultPutObjectOptions { pooContentEncoding = Just "identity" } @@ -390,7 +393,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "create server object with content-language" inputFile <- mkRandFile size1 - fPutObject bucket object inputFile def{ + fPutObject bucket object inputFile defaultPutObjectOptions { pooContentLanguage = Just "en-US" } @@ -418,11 +421,11 @@ liveServerUnitTests = testGroup "Unit tests against a live server" inputFile' <- mkRandFile size1 inputFile'' <- mkRandFile size0 - fPutObject bucket object inputFile def{ + fPutObject bucket object inputFile defaultPutObjectOptions { pooStorageClass = Just "STANDARD" } - fPutObject bucket object' inputFile' def{ + fPutObject bucket object' inputFile' defaultPutObjectOptions { pooStorageClass = Just "REDUCED_REDUNDANCY" } @@ -436,7 +439,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY") (Map.lookup "X-Amz-Storage-Class" m') - fpE <- try $ fPutObject bucket object'' inputFile'' def{ + fpE <- try $ fPutObject bucket object'' inputFile'' defaultPutObjectOptions { pooStorageClass = Just "INVALID_STORAGE_CLASS" } case fpE of @@ -455,10 +458,10 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "create server object to copy" inputFile <- mkRandFile size1 - fPutObject bucket object inputFile def + fPutObject bucket object inputFile defaultPutObjectOptions step "copy object" - let srcInfo = def { srcBucket = bucket, srcObject = object} + let srcInfo = defaultSourceInfo { srcBucket = bucket, srcObject = object} (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo [] -- retrieve obj info to check @@ -484,15 +487,15 @@ liveServerUnitTests = testGroup "Unit tests against a live server" let mb15 = 15 * 1024 * 1024 mb5 = 5 * 1024 * 1024 randFile <- mkRandFile mb15 - fPutObject bucket srcObj randFile def + fPutObject bucket srcObj randFile defaultPutObjectOptions step "create new multipart upload" uid <- newMultipartUpload bucket copyObj [] liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." step "put object parts 1-3" - let srcInfo' = def { srcBucket = bucket, srcObject = srcObj } - dstInfo' = def { dstBucket = bucket, dstObject = copyObj } + let srcInfo' = defaultSourceInfo { srcBucket = bucket, srcObject = srcObj } + dstInfo' = defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } parts <- forM [1..3] $ \p -> do (etag', _) <- copyObjectPart dstInfo' srcInfo'{ srcRange = Just $ (,) ((p-1)*mb5) ((p-1)*mb5 + (mb5 - 1)) @@ -520,11 +523,11 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "Prepare" forM_ (zip srcs sizes) $ \(src, size) -> do inputFile' <- mkRandFile size - fPutObject bucket src inputFile' def + fPutObject bucket src inputFile' defaultPutObjectOptions step "make small and large object copy" forM_ (zip copyObjs srcs) $ \(cp, src) -> - copyObject def {dstBucket = bucket, dstObject = cp} def{srcBucket = bucket, srcObject = src} + copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src} step "verify uploaded objects" uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket) @@ -539,10 +542,10 @@ liveServerUnitTests = testGroup "Unit tests against a live server" step "Prepare" inputFile' <- mkRandFile size - fPutObject bucket src inputFile' def + fPutObject bucket src inputFile' defaultPutObjectOptions step "copy last 10MiB of object" - copyObject def { dstBucket = bucket, dstObject = copyObj } def{ + copyObject defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } defaultSourceInfo { srcBucket = bucket , srcObject = src , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1) @@ -586,21 +589,21 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) step "singlepart putObject works" - fPutObject bucket "lsb-release" "/etc/lsb-release" def + fPutObject bucket "lsb-release" "/etc/lsb-release" defaultPutObjectOptions step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" - fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" def + fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" defaultPutObjectOptions case fpE of Left exn -> liftIO $ exn @?= NoSuchBucket _ -> return () outFile <- mkRandFile 0 step "simple fGetObject works" - fGetObject bucket "lsb-release" outFile def + fGetObject bucket "lsb-release" outFile defaultGetObjectOptions let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857 step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception" - resE <- try $ fGetObject bucket "lsb-release" outFile def{ + resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { gooIfUnmodifiedSince = (Just unmodifiedTime) } case resE of @@ -608,7 +611,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do _ -> return () step "fGetObject an object with no matching etag, check for exception" - resE1 <- try $ fGetObject bucket "lsb-release" outFile def{ + resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { gooIfMatch = (Just "invalid-etag") } case resE1 of @@ -616,7 +619,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do _ -> return () step "fGetObject an object with no valid range, check for exception" - resE2 <- try $ fGetObject bucket "lsb-release" outFile def{ + resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { gooRange = (Just $ HT.ByteRangeFromTo 100 200) } case resE2 of @@ -624,12 +627,12 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do _ -> return () step "fGetObject on object with a valid range" - fGetObject bucket "lsb-release" outFile def{ + fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { gooRange = (Just $ HT.ByteRangeFrom 1) } step "fGetObject a non-existent object and check for NoSuchKey exception" - resE3 <- try $ fGetObject bucket "noSuchKey" outFile def + resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions case resE3 of Left exn -> liftIO $ exn @?= NoSuchKey _ -> return () @@ -648,7 +651,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do let object = "sample" step "create an object" inputFile <- mkRandFile 0 - fPutObject bucket object inputFile def + fPutObject bucket object inputFile defaultPutObjectOptions step "get metadata of the object" res <- statObject bucket object @@ -814,7 +817,7 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ let obj = "myobject" step "verify bucket policy: (1) create `myobject`" - putObject bucket obj (replicateC 100 "c") Nothing def + putObject bucket obj (replicateC 100 "c") Nothing defaultPutObjectOptions step "verify bucket policy: (2) get `myobject` anonymously" connInfo <- asks mcConnInfo diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs index ffac7ff..24b482c 100644 --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -23,8 +23,6 @@ import Test.Tasty.HUnit import Lib.Prelude -import Data.Default (def) - import Network.Minio.Data import Network.Minio.TestHelpers import Network.Minio.XmlGenerator @@ -74,7 +72,7 @@ testMkPutNotificationRequest = [ NotificationConfig "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4" "arn:aws:sns:us-east-1:account-id:s3notificationtopic2" - [ReducedRedundancyLostObject, ObjectCreated] def + [ReducedRedundancyLostObject, ObjectCreated] defaultFilter ] [] , Notification @@ -86,14 +84,14 @@ testMkPutNotificationRequest = , FilterRule "suffix" ".jpg"]) , NotificationConfig "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue" - [ObjectCreated] def + [ObjectCreated] defaultFilter ] [ NotificationConfig "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2" - [ReducedRedundancyLostObject] def + [ReducedRedundancyLostObject] defaultFilter ] [ NotificationConfig "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail" - [ObjectCreated] def + [ObjectCreated] defaultFilter ] ] diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index 4a705e4..0f7496e 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -19,7 +19,6 @@ module Network.Minio.XmlParser.Test xmlParserTests ) where -import Data.Default (def) import qualified Data.Map as Map import Data.Time (fromGregorian) import Test.Tasty @@ -299,7 +298,7 @@ testParseNotification = do [ NotificationConfig "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4" "arn:aws:sns:us-east-1:account-id:s3notificationtopic2" - [ReducedRedundancyLostObject, ObjectCreated] def + [ReducedRedundancyLostObject, ObjectCreated] defaultFilter ] []) , ("\ @@ -342,15 +341,15 @@ testParseNotification = do FilterRule "suffix" ".jpg"]) , NotificationConfig "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue" - [ObjectCreated] def + [ObjectCreated] defaultFilter ] [ NotificationConfig "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2" - [ReducedRedundancyLostObject] def + [ReducedRedundancyLostObject] defaultFilter ] [ NotificationConfig "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail" - [ObjectCreated] def + [ObjectCreated] defaultFilter ]) ]