1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
{-# LANGUAGE OverloadedLists, OverloadedStrings #-}
module AWS.S3 (tests) where
import AWS.Aeson
import Control.Lens hiding ((.=))
import Data.Char (toLower)
import Data.Monoid ((<>))
import Network.Wreq
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (assertBool)
import qualified Data.ByteString.Char8 as BS8 (ByteString, pack)
-- FIXME: retry create call in case we get the S3 specific "A
-- conflicting conditional operation is currently in progress against
-- this resource. Please try again." error from a previous test run
-- that is still deleting the test bucket. For now the 'create'
-- testcase and all others will fails.
tests :: String -> String -> Options -> Test
tests prefix region baseopts = let
lowerPrefix = map toLower prefix
t = \(mkUrl, label) ->
testGroup (region ++ "_" ++ label) [
testCase "createBucket" $
createBucket mkUrl lowerPrefix region baseopts
, testCase "putObjectJSON" $
putObjectJSON mkUrl lowerPrefix region baseopts
, testCase "getObjectJSON" $
getObjectJSON mkUrl lowerPrefix region baseopts
, testCase "deleteObjectJSON" $
deleteObjectJSON mkUrl lowerPrefix region baseopts
, testCase "deleteBucket" $
deleteBucket mkUrl lowerPrefix region baseopts -- call last
]
in testGroup "s3" $ map t [ (urlPath, "bucket-in-path")
, (urlVHost, "bucket-in-vhost") ]
-- Path based bucket access
createBucket :: MkURL -> String -> String -> Options -> IO ()
createBucket url prefix region baseopts = do
r <- putWith baseopts (url region prefix "testbucket") $
locationConstraint region
assertBool "createBucket 200" $ r ^. responseStatus . statusCode == 200
assertBool "createBucket OK" $ r ^. responseStatus . statusMessage == "OK"
deleteBucket :: MkURL -> String -> String -> Options -> IO ()
deleteBucket url prefix region baseopts = do
r <- deleteWith baseopts (url region prefix "testbucket")
assertBool "deleteBucket 204 - no content" $
r ^. responseStatus . statusCode == 204
assertBool "deleteBucket OK" $
r ^. responseStatus . statusMessage == "No Content"
putObjectJSON :: MkURL -> String -> String -> Options -> IO ()
putObjectJSON url prefix region baseopts = do
-- S3 write object, incl. correct content-type
r <- putWith baseopts (url region prefix "testbucket" ++ "blabla-json") $
object ["test" .= "key", "testdata" .= [1, 2, 3]]
assertBool "putObjectJSON 200" $ r ^. responseStatus . statusCode == 200
assertBool "putObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK"
getObjectJSON :: MkURL -> String -> String -> Options -> IO ()
getObjectJSON url prefix region baseopts = do
r <- getWith baseopts (url region prefix "testbucket" ++ "blabla-json")
assertBool "getObjectJSON 200" $ r ^. responseStatus . statusCode == 200
assertBool "getObjectJSON OK" $ r ^. responseStatus . statusMessage == "OK"
deleteObjectJSON :: MkURL -> String -> String -> Options -> IO ()
deleteObjectJSON url prefix region baseopts = do
r <- deleteWith baseopts (url region prefix "testbucket" ++ "blabla-json")
assertBool "deleteObjectJSON 204 - no content" $
r ^. responseStatus . statusCode == 204
assertBool "deleteObjectJSON OK" $
r ^. responseStatus . statusMessage == "No Content"
type MkURL = String -> String -> String -> String --region prefix bucket
-- see http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region
urlPath :: MkURL
urlPath "us-east-1" prefix bucketname =
"https://s3.amazonaws.com/" ++ prefix ++ bucketname ++ "/"-- uses 'classic'
urlPath region prefix bucketname =
"https://s3-" ++ region ++ ".amazonaws.com/" ++ prefix ++ bucketname ++ "/"
-- Generate a VirtualHost style URL
urlVHost :: MkURL
urlVHost "us-east-1" prefix bucketname =
"https://" ++ prefix ++ bucketname ++ ".s3.amazonaws.com/"
urlVHost region prefix bucketname =
"https://" ++ prefix ++ bucketname ++ ".s3-" ++ region ++ ".amazonaws.com/"
-- see http://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUT.html
-- and http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region
locationConstraint :: String -> BS8.ByteString
locationConstraint "us-east-1" = "" -- no loc needed for classic and Virginia
locationConstraint "external-1" = "" -- no loc needed for Virginia
locationConstraint region = "<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><LocationConstraint>" <> BS8.pack region <> "</LocationConstraint></CreateBucketConfiguration>"
|
