diff --git a/app/Main.hs b/app/Main.hs index 78077fb..0f95769 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,8 +13,7 @@ import Control.Monad.Trans.Resource (runResourceT) main :: IO () main = do - mc <- connect defaultConnectInfo - t <- runResourceT $ runMinio mc $ do + t <- runResourceT $ runMinio defaultConnectInfo $ do res <- getService print res -- case res of diff --git a/minio-hs.cabal b/minio-hs.cabal index 830f3d1..9020244 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,6 +1,6 @@ name: minio-hs version: 0.1.0.0 -synopsis: Initial project template from stack +synopsis: A Minio client library, compatible with S3 like services. description: Please see README.md homepage: https://github.com/donatello/minio-hs#readme license: BSD3 diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 5c816b0..ac973af 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -1,5 +1,29 @@ module Network.Minio - ( module Exports + ( + + D.ConnectInfo(..) + , D.defaultConnectInfo + , D.connect + + , D.Minio + , D.runMinio + + -- * Error handling + ----------------------- + -- | Test + , D.MinioErr(..) + , D.MErrV(..) + + -- * Data Types + ---------------- + -- | Data types representing various object store concepts. + , D.Bucket + , D.Object + , D.BucketInfo(..) + + , S.getService + , S.getLocation + , fGetObject , fPutObject ) where @@ -8,21 +32,10 @@ module Network.Minio This module exports the high-level Minio API for object storage. -} -import Network.Minio.S3API as - Exports ( - getService - , getLocation - ) +import qualified Network.Minio.S3API as S -import Network.Minio.Data as - Exports ( - runMinio - , defaultConnectInfo - , connect - , ConnectInfo(..) - ) +import qualified Network.Minio.Data as D --- import System.FilePath (FilePath) import qualified System.IO as IO import qualified Data.Conduit as C import qualified Control.Monad.Trans.Resource as R @@ -34,11 +47,15 @@ import Network.Minio.Data import Network.Minio.S3API import Network.Minio.Utils +-- | Fetch the object and write it to the given file safely. The +-- object is first written to a temporary file in the same directory +-- and then moved to the given path. fGetObject :: Bucket -> Object -> FilePath -> Minio () fGetObject bucket object fp = do (_, src) <- getObject bucket object [] [] src C.$$+- CB.sinkFileCautious fp +-- | Upload the given file to the given object. fPutObject :: Bucket -> Object -> FilePath -> Minio () fPutObject bucket object fp = do (releaseKey, h) <- allocateReadFile fp diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index b64791c..fee828b 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -46,12 +46,21 @@ defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnectInfo "localhost" 9000 "minio" "minio123" False +-- | +-- Represents a bucket in the object store type Bucket = Text + +-- | +-- Represents an object name type Object = Text --- FIXME: This could be a Sum Type with all defined regions for AWS. +-- | +-- Represents a region +-- TODO: This could be a Sum Type with all defined regions for AWS. type Location = Text +-- | +-- BucketInfo returned for list buckets call data BucketInfo = BucketInfo { biName :: Bucket , biCreationDate :: UTCTime @@ -85,9 +94,13 @@ getPathFromRI ri = B.concat $ parts getRegionFromRI :: RequestInfo -> Text getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) +-- | Various validation errors data MErrV = MErrVSinglePUTSizeExceeded Int64 deriving (Show) +-- | +-- Minio Error data type for various errors/exceptions caught and +-- returned. data MinioErr = MErrMsg ByteString -- generic | MErrHttp HttpException -- http exceptions | MErrXml ByteString -- XML parsing/generation errors @@ -116,19 +129,24 @@ instance MonadBaseControl IO Minio where liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio) restoreM = Minio . restoreM --- MinioConn holds connection info and a connection pool +-- | MinioConn holds connection info and a connection pool data MinioConn = MinioConn { mcConnInfo :: ConnectInfo , mcConnManager :: NC.Manager } +-- | Takes connection information and returns a connection object to +-- be passed to @runMinio connect :: ConnectInfo -> IO MinioConn connect ci = do mgr <- NC.newManager defaultManagerSettings return $ MinioConn ci mgr -runMinio :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a) -runMinio conn = runExceptT . flip runReaderT conn . unMinio +-- | Run the Minio action and return the result or error. +runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) +runMinio ci m = do + conn <- liftIO $ connect ci + runExceptT . flip runReaderT conn . unMinio $ m s3Name :: Text -> Name s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index d39345f..2164a4f 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -23,12 +23,14 @@ import Network.Minio.XmlParser import Network.Minio.XmlGenerator +-- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do resp <- executeRequest $ requestInfo HT.methodGet Nothing Nothing [] [] EPayload parseListBuckets $ NC.responseBody resp +-- | Fetch bucket location (region) getLocation :: Bucket -> Minio Text getLocation bucket = do resp <- executeRequest $ @@ -36,6 +38,8 @@ getLocation bucket = do EPayload parseLocation $ NC.responseBody resp +-- | GET an object from the service and return the response headers +-- and a conduit source for the object content getObject :: Bucket -> Object -> HT.Query -> [HT.Header] -> Minio ([HT.Header], C.ResumableSource Minio ByteString) getObject bucket object queryParams headers = do @@ -45,15 +49,19 @@ getObject bucket object queryParams headers = do reqInfo = requestInfo HT.methodGet (Just bucket) (Just object) queryParams headers EPayload +-- | Creates a bucket via a PUT bucket call. putBucket :: Bucket -> Location -> Minio () putBucket bucket location = do void $ executeRequest $ requestInfo HT.methodPut (Just bucket) Nothing [] [] $ PayloadBS $ mkCreateBucketConfig location +-- | Single PUT object size. maxSinglePutObjectSizeBytes :: Int64 maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024 +-- | PUT an object into the service. This function performs a single +-- PUT object calls, and so can only transfer objects upto 5GiB. putObject :: Bucket -> Object -> [HT.Header] -> Int64 -> Int64 -> Handle -> Minio () putObject bucket object headers offset size h = do @@ -66,12 +74,13 @@ putObject bucket object headers offset size h = do requestInfo HT.methodPut (Just bucket) (Just object) [] headers $ PayloadH h offset size - +-- | DELETE a bucket from the service. deleteBucket :: Bucket -> Minio () deleteBucket bucket = do void $ executeRequest $ requestInfo HT.methodDelete (Just bucket) Nothing [] [] EPayload +-- | DELETE an object from the service. deleteObject :: Bucket -> Object -> Minio () deleteObject bucket object = do void $ executeRequest $ diff --git a/test/Spec.hs b/test/Spec.hs index 85041e4..2660b80 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -20,7 +20,7 @@ main = defaultMain tests -- main = putStrLn ("Test suite not yet implemented" :: Text) tests :: TestTree -tests = testGroup "Tests" [properties, unitTests] +tests = testGroup "Tests" [properties, unitTests, liveServerUnitTests] properties :: TestTree properties = testGroup "Properties" [] -- [scProps, qcProps] @@ -47,46 +47,31 @@ properties = testGroup "Properties" [] -- [scProps, qcProps] -- (n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer) -- ] -unitTests :: TestTree -unitTests = testGroup "Unit tests" - [ testCaseSteps "Check getService returns without exception" $ \step -> do - step "Preparing..." - - mc <- connect defaultConnectInfo - - step "Running test.." - ret <- runResourceT $ runMinio mc $ getService +liveServerUnitTests :: TestTree +liveServerUnitTests = testGroup "Unit tests against a live server" + [ testCase "Check getService returns without exception" $ do + ret <- runResourceT $ runMinio defaultConnectInfo $ getService isRight ret @? ("getService failure => " ++ show ret) - , testCaseSteps "Simple fGetObject works" $ \step -> do - step "Preparing..." - mc <- connect defaultConnectInfo - - step "Running test.." - ret <- runResourceT $ runMinio mc $ + , testCase "Simple fGetObject works" $ do + ret <- runResourceT $ runMinio defaultConnectInfo $ fGetObject "testbucket" "lsb-release" "/tmp/out" isRight ret @? ("fGetObject failure => " ++ show ret) - , testCaseSteps "Simple putObject works" $ \step -> do - step "Preparing..." - - mc <- connect defaultConnectInfo - - step "Running test.." - ret <- runResourceT $ runMinio mc $ + , testCase "Simple putObject works" $ do + ret <- runResourceT $ runMinio defaultConnectInfo $ fPutObject "testbucket" "lsb-release" "/etc/lsb-release" isRight ret @? ("putObject failure => " ++ show ret) - , testCaseSteps "Simple putObject fails with non-existent file" $ \step -> do - step "Preparing..." - - mc <- connect defaultConnectInfo - - step "Running test.." - ret <- runResourceT $ runMinio mc $ + , testCase "Simple putObject fails with non-existent file" $ do + ret <- runResourceT $ runMinio defaultConnectInfo $ fPutObject "testbucket" "lsb-release" "/etc/lsb-releaseXXX" isLeft ret @? ("putObject unexpected success => " ++ show ret) + ] + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "Test mkCreateBucketConfig." testMkCreateBucketConfig - , testCase "Test mkCreateBucketConfig." testMkCreateBucketConfig , testCase "Test parseLocation." testParseLocation ]