haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Remove dependency on text-format lib and fix bucket policy test (#86)

Browse Source
This commit is contained in:
Aditya Manthramurthy 2018-05-11 17:48:34 -07:00 committed by Harshavardhana
parent 0177953986
commit 522d49452f
8 changed files with 58 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
minio-hs.cabal
View File

@ -63,7 +63,6 @@ library
, memory , memory
, resourcet , resourcet
, text , text
, text-format
, time , time
, transformers , transformers
, unliftio , unliftio
@ -152,7 +151,6 @@ test-suite minio-hs-live-server-test
, tasty-smallcheck , tasty-smallcheck
, temporary , temporary
, text , text
, text-format
, time , time
, transformers , transformers
, unliftio , unliftio
@ -192,7 +190,6 @@ test-suite minio-hs-test
, tasty-smallcheck , tasty-smallcheck
, temporary , temporary
, text , text
, text-format
, time , time
, transformers , transformers
, unliftio , unliftio

25
src/Lib/Prelude.hs
View File

@ -17,29 +17,16 @@
module Lib.Prelude module Lib.Prelude
( module Exports ( module Exports
, both , both
, format
, formatBS
) where ) where
import Protolude as Exports import Protolude as Exports
import Data.Time as Exports (UTCTime(..), diffUTCTime) import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT)
import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..)) import Data.Time as Exports (UTCTime (..),
diffUTCTime)
import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch) import Control.Monad.Catch as Exports (MonadCatch, MonadThrow,
throwM)
import Data.Text.Format as Exports (Shown(..))
import qualified Data.Text.Format as TF
import Data.Text.Format.Params (Params)
format :: Params ps => TF.Format -> ps -> Text
format f args = toS $ TF.format f args
formatBS :: Params ps => TF.Format -> ps -> ByteString
formatBS f args = toS $ TF.format f args
-- import Data.Tuple as Exports (uncurry)
-- | Apply a function on both elements of a pair -- | Apply a function on both elements of a pair
both :: (a -> b) -> (a, a) -> (b, b) both :: (a -> b) -> (a, a) -> (b, b)

26
src/Network/Minio/API.hs
View File

@ -28,18 +28,18 @@ module Network.Minio.API
, checkObjectNameValidity , checkObjectNameValidity
) where ) where
import qualified Data.Conduit as C import qualified Data.ByteString as B
import Data.Conduit.Binary (sourceHandleRange) import qualified Data.Char as C
import Data.Default (def) import qualified Data.Conduit as C
import qualified Data.Map as Map import Data.Conduit.Binary (sourceHandleRange)
import qualified Data.Char as C import Data.Default (def)
import qualified Data.Text as T import qualified Data.Map as Map
import qualified Data.ByteString as B import qualified Data.Text as T
import Network.HTTP.Conduit (Response) import Network.HTTP.Conduit (Response)
import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Conduit as NC
import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types as HT
import Network.HTTP.Types.Header (hHost) import Network.HTTP.Types.Header (hHost)
import Lib.Prelude import Lib.Prelude
@ -128,9 +128,7 @@ buildRequest ri = do
-- otherwise compute sha256 -- otherwise compute sha256
| otherwise -> getPayloadSHA256Hash (riPayload ri) | otherwise -> getPayloadSHA256Hash (riPayload ri)
let hostHeader = (hHost, formatBS "{}:{}" [connectHost ci, let hostHeader = (hHost, getHostAddr ci)
show $ connectPort ci])
newRi = ri { riPayloadHash = Just sha256Hash newRi = ri { riPayloadHash = Just sha256Hash
, riHeaders = hostHeader , riHeaders = hostHeader
: sha256Header sha256Hash : sha256Header sha256Hash

10
src/Network/Minio/Data.hs
View File

@ -24,13 +24,13 @@ import qualified Control.Monad.Catch as MC
import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..), import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..),
askUnliftIO, withUnliftIO) askUnliftIO, withUnliftIO)
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.CaseInsensitive (mk) import Data.CaseInsensitive (mk)
import Data.Default (Default (..)) import Data.Default (Default (..))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time (defaultTimeLocale, formatTime) import Data.Time (defaultTimeLocale, formatTime)
import GHC.Show (Show (show))
import Network.HTTP.Client (defaultManagerSettings) import Network.HTTP.Client (defaultManagerSettings)
import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Conduit as NC
import Network.HTTP.Types (ByteRange, Header, Method, Query, import Network.HTTP.Types (ByteRange, Header, Method, Query,
@ -39,8 +39,6 @@ import qualified Network.HTTP.Types as HT
import Network.Minio.Errors import Network.Minio.Errors
import Text.XML import Text.XML
import GHC.Show (Show (..))
import Lib.Prelude import Lib.Prelude
-- | max obj size is 5TiB -- | max obj size is 5TiB
@ -99,6 +97,12 @@ data ConnectInfo = ConnectInfo {
instance Default ConnectInfo where instance Default ConnectInfo where
def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True
getHostAddr :: ConnectInfo -> ByteString
getHostAddr ci = toS $ T.concat [ connectHost ci, ":"
, Lib.Prelude.show $ connectPort ci
]
-- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials -- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials
-- should be supplied before use, for e.g.: -- should be supplied before use, for e.g.:
-- --

9
src/Network/Minio/PresignedOperations.hs
View File

@ -71,8 +71,7 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
ci <- asks mcConnInfo ci <- asks mcConnInfo
let let
host = formatBS "{}:{}" (connectHost ci, connectPort ci) hostHeader = (hHost, getHostAddr ci)
hostHeader = (hHost, host)
ri = def { riMethod = method ri = def { riMethod = method
, riBucket = bucket , riBucket = bucket
, riObject = object , riObject = object
@ -89,7 +88,8 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
return $ toS $ toLazyByteString $ return $ toS $ toLazyByteString $
scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr scheme <> byteString (getHostAddr ci) <> byteString (getPathFromRI ri) <>
queryStr
-- | Generate a URL with authentication signature to PUT (upload) an -- | Generate a URL with authentication signature to PUT (upload) an
-- object. Any extra headers if passed, are signed, and so they are -- object. Any extra headers if passed, are signed, and so they are
@ -272,10 +272,9 @@ presignedPostPolicy p = do
-- compute POST upload URL -- compute POST upload URL
bucket = Map.findWithDefault "" "bucket" formData bucket = Map.findWithDefault "" "bucket" formData
scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
host = formatBS "{}:{}" (connectHost ci, connectPort ci)
region = connectRegion ci region = connectRegion ci
url = toS $ toLazyByteString $ scheme <> byteString host <> url = toS $ toLazyByteString $ scheme <> byteString (getHostAddr ci) <>
byteString "/" <> byteString (toS bucket) <> byteString "/" byteString "/" <> byteString (toS bucket) <> byteString "/"
return (url, formData) return (url, formData)

6
src/Network/Minio/S3API.hs
View File

@ -280,8 +280,10 @@ putObjectPart bucket object uploadId partNumber headers payload = do
] ]
srcInfoToHeaders :: SourceInfo -> [HT.Header] srcInfoToHeaders :: SourceInfo -> [HT.Header]
srcInfoToHeaders srcInfo = ("x-amz-copy-source", encodeUtf8 $ format "/{}/{}" [srcBucket srcInfo, srcObject srcInfo]) : srcInfoToHeaders srcInfo = ("x-amz-copy-source",
rangeHdr ++ zip names values toS $ T.concat ["/", srcBucket srcInfo,
"/", srcObject srcInfo]
) : rangeHdr ++ zip names values
where where
names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match", 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-unmodified-since",

25
test/LiveServer.hs
View File

@ -19,6 +19,7 @@ import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Tasty.QuickCheck as QC import Test.Tasty.QuickCheck as QC
import Conduit (replicateC)
import qualified Control.Monad.Catch as MC import qualified Control.Monad.Catch as MC
import qualified Control.Monad.Trans.Resource as R import qualified Control.Monad.Trans.Resource as R
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@ -798,7 +799,7 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist" Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
_ -> return () _ -> return ()
let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"],\"Sid\":\"\"},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"],\"Sid\":\"\"}]}" let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"]}]}"
step "try a malformed policy, expect error" step "try a malformed policy, expect error"
resE'' <- MC.try $ setBucketPolicy bucket expectedPolicyJSON resE'' <- MC.try $ setBucketPolicy bucket expectedPolicyJSON
@ -806,14 +807,28 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "Policy has invalid resource." Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "Policy has invalid resource."
_ -> return () _ -> return ()
let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"],\"Sid\":\"\"},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"],\"Sid\":\"\"}]}" let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"]}]}"
step "set bucket policy" step "set bucket policy"
setBucketPolicy bucket expectedPolicyJSON' setBucketPolicy bucket expectedPolicyJSON'
step "verify if bucket policy was properly set" let obj = "myobject"
policyJSON <- getBucketPolicy bucket
liftIO $ policyJSON @?= expectedPolicyJSON' step "verify bucket policy: (1) create `myobject`"
putObject bucket obj (replicateC 100 "c") Nothing def
step "verify bucket policy: (2) get `myobject` anonymously"
connInfo <- asks mcConnInfo
let proto = bool "http://" "https://" $ connectIsSecure connInfo
url = BS.concat [proto, getHostAddr connInfo, "/", toS bucket,
"/", toS obj]
respE <- liftIO $ (fmap (Right . toS) $ NC.simpleHttp $ toS url) `catch`
(\(e :: NC.HttpException) -> return $ Left (show e :: Text))
case respE of
Left err -> liftIO $ assertFailure $ show err
Right s -> liftIO $ s @?= (BS.concat $ replicate 100 "c")
deleteObject bucket obj
step "delete bucket policy" step "delete bucket policy"
setBucketPolicy bucket T.empty setBucketPolicy bucket T.empty

9
test/Network/Minio/API/Test.hs
View File

@ -19,13 +19,14 @@ module Network.Minio.API.Test
, objectNameValidityTests , objectNameValidityTests
) where ) where
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Lib.Prelude import Lib.Prelude
import Network.Minio.API import Network.Minio.API
assertBool' :: Bool -> Assertion
assertBool' = assertBool "Test failed!" assertBool' = assertBool "Test failed!"
bucketNameValidityTests :: TestTree bucketNameValidityTests :: TestTree