{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- WARNING
-- Run at your own risk!
--
-- Running the tests in this module requires an active Digital Ocean spaces
-- subscription, and may incur any of the following:
--
-- * charges billed to your DO account
-- * the application of rate-limiting or other limits to your account
-- * overage in data transfer or concurrent active spaces, resulting in
-- charges or penalties
-- * the creation of extraneous spaces/buckets in your subscription
-- * data loss or corruption
--
-- To run:
-- * copy ./creds.conf.skel to ./creds.conf
-- * replace the dummy values with your active Spaces access and
-- secret keys, a region slug, and the name of an existing bucket
-- to use for certain object CRUD operations
-- * do not add any additional fields, whitespace, quotes, etc... or
-- parsing the credentials file will fail
-- * run @cabal test@ with @-f test-io@
--
-- The tests will create buckets and attempt to delete them. In the event
-- that bucket deletion fails, you will have to clean them up manually.
-- Similarly, the default bucket provided in the "bucket" field of the
-- credentials file will be used to test certain object CRUD functionality.
-- Although the tests will attempt to delete any objects created, you may
-- need to delete them manually if this fails
--
module Main where
import Conduit
( (.|)
, runConduitRes
, sinkList
, sourceFile
, sourceLazy
)
import Control.Exception ( bracket, throwIO )
import Control.Monad ( void )
import Control.Monad.Catch ( MonadCatch(catch)
, MonadThrow(throwM)
)
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy.Char8 as LC
import Data.Coerce ( coerce )
import qualified Data.Conduit.Binary as CB
import Data.Generics.Labels ()
import qualified Data.Text as T
import Data.Text ( Text )
import qualified Data.Text.Encoding as T
import Data.Time.Clock.POSIX ( getPOSIXTime )
import Lens.Micro
import Lens.Micro.GHC ()
import Network.DO.Spaces
import Network.DO.Spaces.Utils ( slugToRegion )
import qualified Network.HTTP.Types as H
import System.Time.Extra ( sleep )
import Test.Hspec
main :: IO ()
main = sequence_ [ bucketCreateDelete
, bucketActions
, objectCreateDelete
, objectActions
, multipart
]
objectActions :: IO ()
objectActions = do
(bucket, spaces) <- readConf
hspec . around withTestObject $ do
describe "Network.DO.Spaces.Actions.GetObjectInfo"
. it "retrieves object information"
$ \object -> do
info <- retry404 20 . runSpaces spaces
$ getObjectInfo bucket object
(info ^. #result . #contentType) `shouldBe` "text/plain"
(info ^. #result . #contentLength) `shouldBe` 18
describe "Network.DO.Spaces.Actions.CopyObject"
. it "copies an existing object to a new object"
$ \object -> do
destObject <- nameWithEpoch mkObject "test-object-copy-"
copied <- runSpaces spaces
$ copyObjectWithin bucket object destObject
getStatus copied `shouldBe` Just 200
deleted <- retry404 20 . runSpaces spaces
$ deleteObject bucket destObject
getStatus deleted `shouldBe` Just 204
describe "Network.DO.Spaces.Actions.GetObject"
. it "retrieves object data"
$ \object -> do
gotten <- runSpaces spaces $ getObject bucket object
(gotten ^. #result . #objectData)
`shouldBe` "hello from haskell"
where
withTestObject = bracket uploadTestObject deleteTestObject
uploadTestObject = do
(bucket, spaces) <- readConf
object <- nameWithEpoch mkObject "test-object-"
void . runSpaces spaces
$ uploadObject (Just "text/plain") bucket object body
return object
where
body = sourceLazy "hello from haskell"
deleteTestObject object = do
(bucket, spaces) <- readConf
void . runSpaces spaces $ deleteObject bucket object
multipart :: IO ()
multipart = do
(bucket, spaces) <- readConf
object <- nameWithEpoch mkObject "test-multipart-"
hspec
. after_ (cleanup spaces bucket object)
. describe "Network.DO.Spaces.multipartObject"
. it "uploads a multipart object"
$ do
mp <- runSpaces spaces
$ multipartObject Nothing bucket object 5242880 body
getStatus mp `shouldBe` Just 200
(mp ^. #result . #object) `shouldBe` object
where
cleanup spaces bucket object =
void . retry404 20 . runSpaces spaces $ deleteObject bucket object
body = sourceLazy $ LC.replicate 10485760 'f'
objectCreateDelete :: IO ()
objectCreateDelete = do
(bucket, spaces) <- readConf
object <- nameWithEpoch mkObject "test-object-"
hspec
. context "Network.DO.Spaces.Actions Object CRUD"
. it "creates, reads, and deletes a new Object"
$ do
created
<- runSpaces spaces $ uploadObject Nothing bucket object body
getStatus created `shouldBe` Just 200
deleted
<- retry404 20 . runSpaces spaces $ deleteObject bucket object
getStatus deleted `shouldBe` Just 204
(deleted ^. #result) `shouldBe` ()
where
body = sourceLazy "hello from haskell"
bucketActions :: IO ()
bucketActions = do
(bucket, spaces) <- readConf
hspec $ do
describe "Network.DO.Spaces.Actions.GetBucketLocation"
. it "retrieves a bucket's location"
$ do
location <- runSpaces spaces $ getBucketLocation bucket
getStatus location `shouldBe` Just 200
(location ^. #result . #locationConstraint)
`shouldBe` (spaces ^. #region)
describe "Network.DO.Spaces.Actions.ListAllBuckets"
. it "lists account owner's buckets"
$ do
allBuckets <- runSpaces spaces listAllBuckets
(allBuckets ^.. #result . #buckets . each . #name)
`shouldContain` [ bucket ]
bucketCreateDelete :: IO ()
bucketCreateDelete = do
(_, spaces) <- readConf
bucket <- nameWithEpoch mkBucket "do-spaces-test-"
hspec
. context "Network.DO.Spaces.Actions Bucket CRUD"
. it "creates, reads, and deletes a new bucket"
$ do
created <- runSpaces spaces $ createBucket bucket Nothing Nothing
getStatus created `shouldBe` Just 200
(created ^. #result) `shouldBe` ()
deleted <- retry404 20 . runSpaces spaces $ deleteBucket bucket
getStatus deleted `shouldBe` Just 204
(deleted ^. #result) `shouldBe` ()
-- A crude (yet effective) mechanism to ensure that 404s are retried (up to a
-- limit), necessary when creating a new Bucket for testing
retry404 :: (MonadCatch m, MonadIO m)
=> Int
-> m (SpacesResponse a)
-> m (SpacesResponse a)
retry404 maxRetries action = loop 0
where
loop n = catch @_ @ClientException action (catch404 n)
catch404 n e@(HTTPStatus s _)
| H.statusCode s == 404, n < maxRetries = liftIO (sleep 1)
>> loop (n + 1)
| otherwise = throwM e
catch404 _ e = throwM e
-- Makes a Bucket or Object name by appending the current epoch time to a base name;
-- this provides some mechanism to avoid name clashes when creating new buckets,
-- which must be unique across all users within a given region. It also helps ensure
-- that new Objects created during testing won't overwrite existing ones in the
-- default Bucket provided in the credentials configuration
nameWithEpoch :: MonadIO m => (Text -> m a) -> Text -> m a
nameWithEpoch f base = f . (base <>) . T.pack . show @Integer . round
=<< liftIO getPOSIXTime
readConf :: IO (Bucket, Spaces)
readConf = do
contents <- runConduitRes
$ sourceFile "./io-tests/creds.conf" .| CB.lines .| sinkList
case getVal <$> contents of
[ a, s, r, b ] -> do
let access = coerce a
secret = coerce s
region <- slugToRegion $ T.decodeUtf8 r
bucket <- mkBucket $ T.decodeUtf8 b
spaces <- newSpaces region (Explicit access secret)
return (bucket, spaces)
_ -> throwIO . userError
$ mconcat [ "io-tests: Credentials must consist of "
, "exactly four lines, in the order "
, "'access', 'secret', 'region', 'bucket'"
, "with each key separated from its "
, "value with '=', without whitespace "
, "See ./creds.conf.skel"
]
where
getVal = snd . C.splitAt 7
getStatus :: SpacesResponse a -> Maybe Int
getStatus = (^? #metadata . _Just . #status . to H.statusCode)