{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Network.Minio.Data where
import qualified Conduit as C
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as M
import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..),
askUnliftIO, withUnliftIO)
import Control.Monad.Trans.Resource
import qualified Data.Aeson as A
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.CaseInsensitive (mk)
import qualified Data.HashMap.Strict as H
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 qualified Network.Connection as Conn
import Network.HTTP.Client (defaultManagerSettings)
import qualified Network.HTTP.Client.TLS as TLS
import qualified Network.HTTP.Conduit as NC
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
import Lib.Prelude
import Network.Minio.Data.Crypto
maxObjectSize :: Int64
maxObjectSize = 5 * 1024 * 1024 * oneMiB
minPartSize :: Int64
minPartSize = 64 * oneMiB
oneMiB :: Int64
oneMiB = 1024 * 1024
maxMultipartParts :: Int64
maxMultipartParts = 10000
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")
]
data ConnectInfo =
ConnectInfo { connectHost :: Text
, connectPort :: Int
, connectAccessKey :: Text
, connectSecretKey :: Text
, connectIsSecure :: Bool
, connectRegion :: Region
, connectAutoDiscoverRegion :: Bool
, connectDisableTLSCertValidation :: Bool
} deriving (Eq, Show)
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
, connectDisableTLSCertValidation = False
}
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
}
isConnectInfoSecure :: ConnectInfo -> Bool
isConnectInfoSecure = connectIsSecure
disableTLSCertValidation :: ConnectInfo -> ConnectInfo
disableTLSCertValidation c = c { connectDisableTLSCertValidation = True }
getHostAddr :: ConnectInfo -> ByteString
getHostAddr ci = if | port == 80 || port == 443 -> toS host
| otherwise -> toS $
T.concat [ host, ":" , Lib.Prelude.show port]
where
port = connectPort ci
host = connectHost ci
gcsCI :: ConnectInfo
gcsCI = setRegion "us"
"https://storage.googleapis.com"
awsCI :: ConnectInfo
awsCI = "https://s3.amazonaws.com"
minioPlayCI :: ConnectInfo
minioPlayCI = let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"
in setCreds playCreds
$ setRegion "us-east-1"
"https://play.min.io:9000"
type Bucket = Text
type Object = Text
type Region = Text
type ETag = Text
newtype SSECKey = SSECKey BA.ScrubbedBytes
deriving (Eq, Show)
mkSSECKey :: MonadThrow m => ByteString -> m SSECKey
mkSSECKey keyBytes | B.length keyBytes /= 32 =
throwM MErrVInvalidEncryptionKeyLength
| otherwise =
return $ SSECKey $ BA.convert keyBytes
data SSE where
SSE :: SSE
SSEKMS :: A.ToJSON a => Maybe ByteString -> Maybe a -> SSE
SSEC :: SSECKey -> SSE
toPutObjectHeaders :: SSE -> [HT.Header]
toPutObjectHeaders sseArg =
let sseHeader = "x-amz-server-side-encryption"
sseKmsIdHeader = sseHeader <> "-aws-kms-key-id"
sseKmsContextHeader = sseHeader <> "-context"
ssecAlgo = sseHeader <> "-customer-algorithm"
ssecKey = sseHeader <> "-customer-key"
ssecKeyMD5 = ssecKey <> "-MD5"
in case sseArg of
SSE -> [(sseHeader, "AES256")]
SSEKMS keyIdMay ctxMay ->
[(sseHeader, "aws:kms")] ++
maybe [] (\k -> [(sseKmsIdHeader, k)]) keyIdMay ++
maybe [] (\k -> [(sseKmsContextHeader, toS $ A.encode k)]) ctxMay
SSEC (SSECKey sb) ->
[(ssecAlgo, "AES256"),
(ssecKey, encodeToBase64 sb),
(ssecKeyMD5, hashMD5ToBase64 sb)]
data PutObjectOptions = PutObjectOptions {
pooContentType :: Maybe Text
, pooContentEncoding :: Maybe Text
, pooContentDisposition :: Maybe Text
, pooCacheControl :: Maybe Text
, pooContentLanguage :: Maybe Text
, pooStorageClass :: Maybe Text
, pooUserMetadata :: [(Text, Text)]
, pooNumThreads :: Maybe Word
, pooSSE :: Maybe SSE
}
defaultPutObjectOptions :: PutObjectOptions
defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing
addXAmzMetaPrefix :: Text -> Text
addXAmzMetaPrefix s = do
if (T.isPrefixOf "x-amz-meta-" s)
then s
else T.concat ["x-amz-meta-", s]
mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]
mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ T.toLower x, encodeUtf8 y))
pooToHeaders :: PutObjectOptions -> [HT.Header]
pooToHeaders poo = userMetadata
++ (catMaybes $ map tupToMaybe (zipWith (,) names values))
++ maybe [] toPutObjectHeaders (pooSSE poo)
where
tupToMaybe (k, Just v) = Just (k, v)
tupToMaybe (_, Nothing) = Nothing
userMetadata = mkHeaderFromMetadata $ pooUserMetadata poo
names = ["content-type",
"content-encoding",
"content-disposition",
"content-language",
"cache-control",
"x-amz-storage-class"]
values = map (fmap encodeUtf8 . (poo &))
[pooContentType, pooContentEncoding,
pooContentDisposition, pooContentLanguage,
pooCacheControl, pooStorageClass]
data BucketInfo = BucketInfo {
biName :: Bucket
, biCreationDate :: UTCTime
} deriving (Show, Eq)
type PartNumber = Int16
type UploadId = Text
type PartTuple = (PartNumber, ETag)
data ListPartsResult = ListPartsResult {
lprHasMore :: Bool
, lprNextPart :: Maybe Int
, lprParts :: [ObjectPartInfo]
} deriving (Show, Eq)
data ObjectPartInfo = ObjectPartInfo {
opiNumber :: PartNumber
, opiETag :: ETag
, opiSize :: Int64
, opiModTime :: UTCTime
} deriving (Show, Eq)
data ListUploadsResult = ListUploadsResult {
lurHasMore :: Bool
, lurNextKey :: Maybe Text
, lurNextUpload :: Maybe Text
, lurUploads :: [(Object, UploadId, UTCTime)]
, lurCPrefixes :: [Text]
} deriving (Show, Eq)
data UploadInfo = UploadInfo {
uiKey :: Object
, uiUploadId :: UploadId
, uiInitTime :: UTCTime
, uiSize :: Int64
} deriving (Show, Eq)
data ListObjectsResult = ListObjectsResult {
lorHasMore :: Bool
, lorNextToken :: Maybe Text
, lorObjects :: [ObjectInfo]
, lorCPrefixes :: [Text]
} deriving (Show, Eq)
data ListObjectsV1Result = ListObjectsV1Result {
lorHasMore' :: Bool
, lorNextMarker :: Maybe Text
, lorObjects' :: [ObjectInfo]
, lorCPrefixes' :: [Text]
} deriving (Show, Eq)
data ObjectInfo = ObjectInfo
{ oiObject :: Object
, oiModTime :: UTCTime
, oiETag :: ETag
, oiSize :: Int64
, oiMetadata :: Map.Map Text Text
} deriving (Show, Eq)
data SourceInfo = SourceInfo
{ srcBucket :: Text
, srcObject :: Text
, srcRange :: Maybe (Int64, Int64)
, srcIfMatch :: Maybe Text
, srcIfNoneMatch :: Maybe Text
, srcIfModifiedSince :: Maybe UTCTime
, srcIfUnmodifiedSince :: Maybe UTCTime
} deriving (Show, Eq)
defaultSourceInfo :: SourceInfo
defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing
data DestinationInfo = DestinationInfo
{ dstBucket :: Text
, dstObject :: Text
} deriving (Show, Eq)
defaultDestinationInfo :: DestinationInfo
defaultDestinationInfo = DestinationInfo "" ""
data GetObjectOptions = GetObjectOptions {
gooRange :: Maybe ByteRange
, gooIfMatch :: Maybe ETag
, gooIfNoneMatch :: Maybe ETag
, gooIfUnmodifiedSince :: Maybe UTCTime
, gooIfModifiedSince :: Maybe UTCTime
, gooSSECKey :: Maybe SSECKey
}
defaultGetObjectOptions :: GetObjectOptions
defaultGetObjectOptions =
GetObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing
gooToHeaders :: GetObjectOptions -> [HT.Header]
gooToHeaders goo = rangeHdr ++ zip names values
++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo)
where
names = ["If-Match",
"If-None-Match",
"If-Unmodified-Since",
"If-Modified-Since"]
values = mapMaybe (fmap encodeUtf8 . (goo &))
[gooIfMatch, gooIfNoneMatch,
fmap formatRFC1123 . gooIfUnmodifiedSince,
fmap formatRFC1123 . gooIfModifiedSince]
rangeHdr = maybe [] (\a -> [(hRange, HT.renderByteRanges [a])])
$ gooRange goo
data Event = ObjectCreated
| ObjectCreatedPut
| ObjectCreatedPost
| ObjectCreatedCopy
| ObjectCreatedMultipartUpload
| ObjectRemoved
| ObjectRemovedDelete
| ObjectRemovedDeleteMarkerCreated
| ReducedRedundancyLostObject
deriving (Eq)
instance Show Event where
show ObjectCreated = "s3:ObjectCreated:*"
show ObjectCreatedPut = "s3:ObjectCreated:Put"
show ObjectCreatedPost = "s3:ObjectCreated:Post"
show ObjectCreatedCopy = "s3:ObjectCreated:Copy"
show ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload"
show ObjectRemoved = "s3:ObjectRemoved:*"
show ObjectRemovedDelete = "s3:ObjectRemoved:Delete"
show ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated"
show ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject"
textToEvent :: Text -> Maybe Event
textToEvent t = case t of
"s3:ObjectCreated:*" -> Just ObjectCreated
"s3:ObjectCreated:Put" -> Just ObjectCreatedPut
"s3:ObjectCreated:Post" -> Just ObjectCreatedPost
"s3:ObjectCreated:Copy" -> Just ObjectCreatedCopy
"s3:ObjectCreated:MultipartUpload" -> Just ObjectCreatedMultipartUpload
"s3:ObjectRemoved:*" -> Just ObjectRemoved
"s3:ObjectRemoved:Delete" -> Just ObjectRemovedDelete
"s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated
"s3:ReducedRedundancyLostObject" -> Just ReducedRedundancyLostObject
_ -> Nothing
data Filter = Filter
{ fFilter :: FilterKey
} deriving (Show, Eq)
defaultFilter :: Filter
defaultFilter = Filter defaultFilterKey
data FilterKey = FilterKey
{ fkKey :: FilterRules
} deriving (Show, Eq)
defaultFilterKey :: FilterKey
defaultFilterKey = FilterKey defaultFilterRules
data FilterRules = FilterRules
{ frFilterRules :: [FilterRule]
} deriving (Show, Eq)
defaultFilterRules :: FilterRules
defaultFilterRules = FilterRules []
data FilterRule = FilterRule
{ frName :: Text
, frValue :: Text
} deriving (Show, Eq)
type Arn = Text
data NotificationConfig = NotificationConfig
{ ncId :: Text
, ncArn :: Arn
, ncEvents :: [Event]
, ncFilter :: Filter
} deriving (Show, Eq)
data Notification = Notification
{ nQueueConfigurations :: [NotificationConfig]
, nTopicConfigurations :: [NotificationConfig]
, nCloudFunctionConfigurations :: [NotificationConfig]
} deriving (Eq, Show)
defaultNotification :: Notification
defaultNotification = Notification [] [] []
data SelectRequest = SelectRequest
{ srExpression :: Text
, srExpressionType :: ExpressionType
, srInputSerialization :: InputSerialization
, srOutputSerialization :: OutputSerialization
, srRequestProgressEnabled :: Maybe Bool
} deriving (Eq, Show)
data ExpressionType = SQL
deriving (Eq, Show)
data InputSerialization = InputSerialization
{ isCompressionType :: Maybe CompressionType
, isFormatInfo :: InputFormatInfo
} deriving (Eq, Show)
data CompressionType = CompressionTypeNone
| CompressionTypeGzip
| CompressionTypeBzip2
deriving (Eq, Show)
data InputFormatInfo = InputFormatCSV CSVInputProp
| InputFormatJSON JSONInputProp
| InputFormatParquet
deriving (Eq, Show)
defaultCsvInput :: InputSerialization
defaultCsvInput = InputSerialization Nothing (InputFormatCSV defaultCSVProp)
linesJsonInput :: InputSerialization
linesJsonInput = InputSerialization Nothing
(InputFormatJSON $ JSONInputProp JSONTypeLines)
documentJsonInput :: InputSerialization
documentJsonInput = InputSerialization Nothing
(InputFormatJSON $ JSONInputProp JSONTypeDocument)
defaultParquetInput :: InputSerialization
defaultParquetInput = InputSerialization Nothing InputFormatParquet
setInputCompressionType :: CompressionType -> SelectRequest
-> SelectRequest
setInputCompressionType c i =
let is = srInputSerialization i
is' = is { isCompressionType = Just c }
in i { srInputSerialization = is' }
defaultCsvOutput :: OutputSerialization
defaultCsvOutput = OutputSerializationCSV defaultCSVProp
defaultJsonOutput :: OutputSerialization
defaultJsonOutput = OutputSerializationJSON (JSONOutputProp Nothing)
selectRequest :: Text -> InputSerialization -> OutputSerialization
-> SelectRequest
selectRequest sqlQuery inputSer outputSer =
SelectRequest { srExpression = sqlQuery
, srExpressionType = SQL
, srInputSerialization = inputSer
, srOutputSerialization = outputSer
, srRequestProgressEnabled = Nothing
}
setRequestProgressEnabled :: Bool -> SelectRequest -> SelectRequest
setRequestProgressEnabled enabled sr =
sr { srRequestProgressEnabled = Just enabled }
type CSVInputProp = CSVProp
data CSVProp = CSVProp (H.HashMap Text Text)
deriving (Eq, Show)
#if (__GLASGOW_HASKELL__ >= 804)
instance Semigroup CSVProp where
(CSVProp a) <> (CSVProp b) = CSVProp (b <> a)
#endif
instance Monoid CSVProp where
mempty = CSVProp mempty
#if (__GLASGOW_HASKELL__ < 804)
mappend (CSVProp a) (CSVProp b) = CSVProp (b <> a)
#endif
defaultCSVProp :: CSVProp
defaultCSVProp = mempty
recordDelimiter :: Text -> CSVProp
recordDelimiter = CSVProp . H.singleton "RecordDelimiter"
fieldDelimiter :: Text -> CSVProp
fieldDelimiter = CSVProp . H.singleton "FieldDelimiter"
quoteCharacter :: Text -> CSVProp
quoteCharacter = CSVProp . H.singleton "QuoteCharacter"
quoteEscapeCharacter :: Text -> CSVProp
quoteEscapeCharacter = CSVProp . H.singleton "QuoteEscapeCharacter"
data FileHeaderInfo
= FileHeaderNone
| FileHeaderUse
| FileHeaderIgnore
deriving (Eq, Show)
fileHeaderInfo :: FileHeaderInfo -> CSVProp
fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toString
where
toString FileHeaderNone = "NONE"
toString FileHeaderUse = "USE"
toString FileHeaderIgnore = "IGNORE"
commentCharacter :: Text -> CSVProp
commentCharacter = CSVProp . H.singleton "Comments"
allowQuotedRecordDelimiter :: CSVProp
allowQuotedRecordDelimiter = CSVProp $ H.singleton "AllowQuotedRecordDelimiter" "TRUE"
setInputCSVProps :: CSVProp -> InputSerialization -> InputSerialization
setInputCSVProps p is = is { isFormatInfo = InputFormatCSV p }
outputCSVFromProps :: CSVProp -> OutputSerialization
outputCSVFromProps p = OutputSerializationCSV p
data JSONInputProp = JSONInputProp { jsonipType :: JSONType }
deriving (Eq, Show)
data JSONType = JSONTypeDocument | JSONTypeLines
deriving (Eq, Show)
data OutputSerialization = OutputSerializationJSON JSONOutputProp
| OutputSerializationCSV CSVOutputProp
deriving (Eq, Show)
type CSVOutputProp = CSVProp
quoteFields :: QuoteFields -> CSVProp
quoteFields q = CSVProp $ H.singleton "QuoteFields" $
case q of
QuoteFieldsAsNeeded -> "ASNEEDED"
QuoteFieldsAlways -> "ALWAYS"
data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways
deriving (Eq, Show)
data JSONOutputProp = JSONOutputProp { jsonopRecordDelimiter :: Maybe Text }
deriving (Eq, Show)
outputJSONFromRecordDelimiter :: Text -> OutputSerialization
outputJSONFromRecordDelimiter t =
OutputSerializationJSON (JSONOutputProp $ Just t)
data EventMessage = ProgressEventMessage { emProgress :: Progress }
| StatsEventMessage { emStats :: Stats }
| RequestLevelErrorMessage { emErrorCode :: Text
, emErrorMessage :: Text
}
| RecordPayloadEventMessage { emPayloadBytes :: ByteString }
deriving (Eq, Show)
data MsgHeaderName = MessageType
| EventType
| ContentType
| ErrorCode
| ErrorMessage
deriving (Eq, Show)
msgHeaderValueType :: Word8
msgHeaderValueType = 7
type MessageHeader = (MsgHeaderName, Text)
data Progress = Progress { pBytesScanned :: Int64
, pBytesProcessed :: Int64
, pBytesReturned :: Int64
}
deriving (Eq, Show)
type Stats = Progress
data Payload
= PayloadBS ByteString
| PayloadH Handle Int64 Int64
| PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ())
defaultPayload :: Payload
defaultPayload = PayloadBS ""
data AdminReqInfo = AdminReqInfo {
ariMethod :: Method
, ariPayloadHash :: Maybe ByteString
, ariPayload :: Payload
, ariPath :: ByteString
, ariHeaders :: [Header]
, ariQueryParams :: Query
}
data S3ReqInfo = S3ReqInfo
{ riMethod :: Method
, riBucket :: Maybe Bucket
, riObject :: Maybe Object
, riQueryParams :: Query
, riHeaders :: [Header]
, riPayload :: Payload
, riPayloadHash :: Maybe ByteString
, riRegion :: Maybe Region
, riNeedsLocation :: Bool
}
defaultS3ReqInfo :: S3ReqInfo
defaultS3ReqInfo = S3ReqInfo HT.methodGet Nothing Nothing
[] [] defaultPayload Nothing Nothing True
getS3Path :: Maybe Bucket -> Maybe Object -> ByteString
getS3Path b o =
let segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)
in
B.concat ["/", B.intercalate "/" segments]
type UrlExpiry = Int
type RegionMap = Map.Map Bucket Region
newtype Minio a = Minio {
unMinio :: ReaderT MinioConn (ResourceT IO) a
}
deriving (
Functor
, Applicative
, Monad
, MonadIO
, MonadReader MinioConn
, MonadResource
)
instance MonadUnliftIO Minio where
askUnliftIO = Minio $ ReaderT $ \r ->
withUnliftIO $ \u ->
return (UnliftIO (unliftIO u . flip runReaderT r . unMinio))
data MinioConn = MinioConn
{ mcConnInfo :: ConnectInfo
, mcConnManager :: NC.Manager
, mcRegionMap :: MVar RegionMap
}
class HasSvcNamespace env where
getSvcNamespace :: env -> Text
instance HasSvcNamespace MinioConn where
getSvcNamespace env = let host = connectHost $ mcConnInfo env
in if | host == "storage.googleapis.com" ->
"http://doc.s3.amazonaws.com/2006-03-01"
| otherwise ->
"http://s3.amazonaws.com/doc/2006-03-01/"
connect :: ConnectInfo -> IO MinioConn
connect ci = do
let settings | connectIsSecure ci && connectDisableTLSCertValidation ci =
let badTlsSettings = Conn.TLSSettingsSimple True False False
in TLS.mkManagerSettings badTlsSettings Nothing
| connectIsSecure ci = NC.tlsManagerSettings
| otherwise = defaultManagerSettings
mgr <- NC.newManager settings
mkMinioConn ci mgr
runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)
runMinioWith conn m = runResourceT $ runMinioResWith conn m
mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn
mkMinioConn ci mgr = do
rMapMVar <- M.newMVar Map.empty
return $ MinioConn ci mgr rMapMVar
runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ci m = do
conn <- connect ci
runResourceT $ runMinioResWith conn m
runMinioResWith :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a)
runMinioResWith conn m =
flip runReaderT conn . unMinio $
fmap Right m `U.catches`
[ U.Handler handlerServiceErr
, U.Handler handlerHE
, U.Handler handlerFE
, U.Handler handlerValidation
]
where
handlerServiceErr = return . Left . MErrService
handlerHE = return . Left . MErrHTTP
handlerFE = return . Left . MErrIO
handlerValidation = return . Left . MErrValidation
runMinioRes :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a)
runMinioRes ci m = do
conn <- liftIO $ connect ci
runMinioResWith conn m
s3Name :: Text -> Text -> Name
s3Name ns s = Name s (Just ns) Nothing
formatRFC1123 :: UTCTime -> T.Text
formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"