-- | Tests for the AWS S3 example event source and sink.
module Hydra.Events.S3Spec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Amazonka qualified as AWS
import Amazonka.Auth qualified as AWS
import Hydra.Events (EventId, EventSink (..), getEvents)
import Hydra.Events.S3 (fromObjectKey, newS3EventStore, purgeEvents, toObjectKey)
import Test.QuickCheck (chooseBoundedIntegral, counterexample, forAllShrink, ioProperty, sized, sublistOf, withMaxSuccess, (===))

spec :: Spec
spec :: Spec
spec = do
  String -> (EventId -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"ObjectKey <-> EventId" ((EventId -> Property) -> Spec) -> (EventId -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \EventId
eventId ->
    let key :: ObjectKey
key = EventId -> ObjectKey
forall e. HasEventId e => e -> ObjectKey
toObjectKey EventId
eventId
     in forall (m :: * -> *). MonadFail m => ObjectKey -> m EventId
fromObjectKey @(Either String) ObjectKey
key Either String EventId -> Either String EventId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== EventId -> Either String EventId
forall a b. b -> Either a b
Right EventId
eventId
          Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"ObjectKey: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ObjectKey -> String
forall b a. (Show a, IsString b) => a -> b
show ObjectKey
key)

  -- Only run tests if the AWS environment can be discovered.
  ((BucketName -> IO ()) -> IO ()) -> SpecWith BucketName -> Spec
forall a. (ActionWith a -> IO ()) -> SpecWith a -> Spec
around (BucketName -> IO ()) -> IO ()
forall {t}. IsString t => (t -> IO ()) -> IO ()
onlyWithAWSEnv (SpecWith BucketName -> Spec) -> SpecWith BucketName -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String
-> (BucketName -> Property)
-> SpecWith (Arg (BucketName -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"roundtrip putEvent and sourceEvents" ((BucketName -> Property)
 -> SpecWith (Arg (BucketName -> Property)))
-> (BucketName -> Property)
-> SpecWith (Arg (BucketName -> Property))
forall a b. (a -> b) -> a -> b
$ \BucketName
bucketName ->
      Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
3 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Gen [EventId]
-> ([EventId] -> [[EventId]])
-> ([EventId] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen [EventId]
genContinuousEvents [EventId] -> [[EventId]]
forall a. Arbitrary a => a -> [a]
shrink (([EventId] -> Property) -> Property)
-> ([EventId] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[EventId]
events ->
          IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
            BucketName
-> ((EventSource EventId IO, EventSink EventId IO) -> IO Property)
-> IO Property
forall {e} {c}.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> ((EventSource e IO, EventSink e IO) -> IO c) -> IO c
withS3EventStore BucketName
bucketName (((EventSource EventId IO, EventSink EventId IO) -> IO Property)
 -> IO Property)
-> ((EventSource EventId IO, EventSink EventId IO) -> IO Property)
-> IO Property
forall a b. (a -> b) -> a -> b
$ \(EventSource EventId IO
source, EventSink EventId IO
sink) -> do
              [EventId] -> (EventId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EventId]
events (EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink)
              [EventId]
loadedEvents <- EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source
              Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [EventId]
loadedEvents [EventId] -> [EventId] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [EventId]
events

    String
-> (BucketName -> Property)
-> SpecWith (Arg (BucketName -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"handles non-continuous events" ((BucketName -> Property)
 -> SpecWith (Arg (BucketName -> Property)))
-> (BucketName -> Property)
-> SpecWith (Arg (BucketName -> Property))
forall a b. (a -> b) -> a -> b
$ \BucketName
bucketName ->
      Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
3 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Gen [EventId]
-> ([EventId] -> [[EventId]])
-> ([EventId] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink ([EventId] -> Gen [EventId]
forall a. [a] -> Gen [a]
sublistOf ([EventId] -> Gen [EventId]) -> Gen [EventId] -> Gen [EventId]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen [EventId]
genContinuousEvents) [EventId] -> [[EventId]]
forall a. Arbitrary a => a -> [a]
shrink (([EventId] -> Property) -> Property)
-> ([EventId] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[EventId]
events ->
          IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
            BucketName
-> ((EventSource EventId IO, EventSink EventId IO) -> IO Property)
-> IO Property
forall {e} {c}.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> ((EventSource e IO, EventSink e IO) -> IO c) -> IO c
withS3EventStore BucketName
bucketName (((EventSource EventId IO, EventSink EventId IO) -> IO Property)
 -> IO Property)
-> ((EventSource EventId IO, EventSink EventId IO) -> IO Property)
-> IO Property
forall a b. (a -> b) -> a -> b
$ \(EventSource EventId IO
source, EventSink EventId IO
sink) -> do
              [EventId] -> (EventId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EventId]
events (EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink)
              [EventId]
loadedEvents <- EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source
              Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [EventId]
loadedEvents [EventId] -> [EventId] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [EventId]
events

    String
-> (BucketName -> Property)
-> SpecWith (Arg (BucketName -> Property))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"handles duplicate events" ((BucketName -> Property)
 -> SpecWith (Arg (BucketName -> Property)))
-> (BucketName -> Property)
-> SpecWith (Arg (BucketName -> Property))
forall a b. (a -> b) -> a -> b
$ \BucketName
bucketName ->
      Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
3 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Gen [EventId]
-> ([EventId] -> [[EventId]])
-> ([EventId] -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen [EventId]
genContinuousEvents [EventId] -> [[EventId]]
forall a. Arbitrary a => a -> [a]
shrink (([EventId] -> Property) -> Property)
-> ([EventId] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[EventId]
events ->
          IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
            BucketName
-> ((EventSource EventId IO, EventSink EventId IO) -> IO Property)
-> IO Property
forall {e} {c}.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> ((EventSource e IO, EventSink e IO) -> IO c) -> IO c
withS3EventStore BucketName
bucketName (((EventSource EventId IO, EventSink EventId IO) -> IO Property)
 -> IO Property)
-> ((EventSource EventId IO, EventSink EventId IO) -> IO Property)
-> IO Property
forall a b. (a -> b) -> a -> b
$ \(EventSource EventId IO
source, EventSink EventId IO
sink) -> do
              -- Put some events
              [EventId] -> (EventId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EventId]
events (EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink)
              [EventId]
loadedEvents <- EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source
              -- Put the loaded events again (as the node would do)
              [EventId] -> (EventId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EventId]
loadedEvents (EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink)
              [EventId]
allEvents <- EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source
              Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ [EventId]
allEvents [EventId] -> [EventId] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [EventId]
loadedEvents

    String
-> (BucketName -> IO ()) -> SpecWith (Arg (BucketName -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"allows concurrent usage" ((BucketName -> IO ()) -> SpecWith (Arg (BucketName -> IO ())))
-> (BucketName -> IO ()) -> SpecWith (Arg (BucketName -> IO ()))
forall a b. (a -> b) -> a -> b
$ \BucketName
bucketName -> do
      BucketName
-> ((EventSource EventId IO, EventSink EventId IO) -> IO ())
-> IO ()
forall {e} {c}.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> ((EventSource e IO, EventSink e IO) -> IO c) -> IO c
withS3EventStore BucketName
bucketName (((EventSource EventId IO, EventSink EventId IO) -> IO ())
 -> IO ())
-> ((EventSource EventId IO, EventSink EventId IO) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventSource EventId IO
source, EventSink EventId IO
sink) -> do
        IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
concurrently_
          (EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink EventId
123)
          (EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink EventId
456)
        EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source IO [EventId] -> [EventId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [EventId
123, EventId
456 :: EventId]

    String
-> (BucketName -> IO ()) -> SpecWith (Arg (BucketName -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"supports multiple instances" ((BucketName -> IO ()) -> SpecWith (Arg (BucketName -> IO ())))
-> (BucketName -> IO ()) -> SpecWith (Arg (BucketName -> IO ()))
forall a b. (a -> b) -> a -> b
$ \BucketName
bucketName ->
      IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (BucketName -> IO ()
cleanup BucketName
bucketName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (EventSource EventId IO
source1, EventSink EventId IO
sink1) <- BucketName -> IO (EventSource EventId IO, EventSink EventId IO)
forall e.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> IO (EventSource e IO, EventSink e IO)
newS3EventStore BucketName
bucketName
        (EventSource EventId IO
source2, EventSink EventId IO
sink2) <- BucketName -> IO (EventSource EventId IO, EventSink EventId IO)
forall e.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> IO (EventSource e IO, EventSink e IO)
newS3EventStore BucketName
bucketName
        EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink1 EventId
123
        EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink2 EventId
123
        EventSink EventId IO -> HasEventId EventId => EventId -> IO ()
forall e (m :: * -> *). EventSink e m -> HasEventId e => e -> m ()
putEvent EventSink EventId IO
sink2 EventId
456
        [EventId]
events1 <- EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source1
        [EventId]
events2 <- EventSource EventId IO -> IO [EventId]
forall e (m :: * -> *).
(HasEventId e, MonadUnliftIO m) =>
EventSource e m -> m [e]
getEvents EventSource EventId IO
source2
        [EventId]
events1 [EventId] -> [EventId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [EventId]
events2
        [EventId]
events1 [EventId] -> [EventId] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [EventId
123, EventId
456 :: EventId]
 where
  withS3EventStore :: BucketName -> ((EventSource e IO, EventSink e IO) -> IO c) -> IO c
withS3EventStore BucketName
bucketName =
    IO (EventSource e IO, EventSink e IO)
-> ((EventSource e IO, EventSink e IO) -> IO ())
-> ((EventSource e IO, EventSink e IO) -> IO c)
-> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (BucketName -> IO (EventSource e IO, EventSink e IO)
forall e.
(HasEventId e, ToJSON e, FromJSON e) =>
BucketName -> IO (EventSource e IO, EventSink e IO)
newS3EventStore BucketName
bucketName) (IO () -> (EventSource e IO, EventSink e IO) -> IO ()
forall a b. a -> b -> a
const (IO () -> (EventSource e IO, EventSink e IO) -> IO ())
-> IO () -> (EventSource e IO, EventSink e IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ BucketName -> IO ()
cleanup BucketName
bucketName)

  -- See https://hackage.haskell.org/package/amazonka-2.0/docs/Amazonka-Auth.html#v:fromKeysEnv
  --
  -- Also provides the BucketName to tests. We are using 'fromString' to avoid the
  -- dependency onto amazonka-s3 in the test suite.
  onlyWithAWSEnv :: (t -> IO ()) -> IO ()
onlyWithAWSEnv t -> IO ()
action = do
    IO Env -> IO (Either AuthError Env)
forall e a. Exception e => IO a -> IO (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ((EnvNoAuth -> IO Env) -> IO Env
forall (m :: * -> *). MonadIO m => (EnvNoAuth -> m Env) -> m Env
AWS.newEnv EnvNoAuth -> IO Env
forall (m :: * -> *) (withAuth :: * -> *).
MonadIO m =>
Env' withAuth -> m Env
AWS.fromKeysEnv) IO (Either AuthError Env)
-> (Either AuthError Env -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (AuthError
_ :: AWS.AuthError) -> HasCallStack => String -> IO ()
String -> IO ()
pendingWith String
"Requires AWS environment"
      Right Env
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    String -> IO (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
lookupEnv String
"BUCKET_NAME" IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe String
Nothing -> HasCallStack => String -> IO ()
String -> IO ()
pendingWith String
"Requires BUCKET_NAME environment variable"
      Just String
bucketName -> do
        t -> IO ()
action (String -> t
forall a. IsString a => String -> a
fromString String
bucketName)

  cleanup :: BucketName -> IO ()
cleanup BucketName
bucketName = do
    Env
env <- (EnvNoAuth -> IO Env) -> IO Env
forall (m :: * -> *). MonadIO m => (EnvNoAuth -> m Env) -> m Env
AWS.newEnv EnvNoAuth -> IO Env
forall (m :: * -> *) (withAuth :: * -> *).
MonadIO m =>
Env' withAuth -> m Env
AWS.fromKeysEnv
    Env -> BucketName -> IO ()
purgeEvents Env
env BucketName
bucketName

genContinuousEvents :: Gen [EventId]
genContinuousEvents :: Gen [EventId]
genContinuousEvents = (Int -> Gen [EventId]) -> Gen [EventId]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [EventId]) -> Gen [EventId])
-> (Int -> Gen [EventId]) -> Gen [EventId]
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
  EventId
w <- (EventId, EventId) -> Gen EventId
forall a. (Bounded a, Integral a) => (a, a) -> Gen a
chooseBoundedIntegral (EventId
0, Int -> EventId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  [EventId] -> Gen [EventId]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [EventId
0 .. EventId
w]