{-# LANGUAGE LambdaCase #-}

module Hydra.PersistenceSpec where

import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude

import Data.Aeson (Value (..))
import Data.Aeson qualified as Aeson
import Data.Text qualified as Text
import Hydra.Persistence (Persistence (..), PersistenceException (..), PersistenceIncremental (..), createPersistence, createPersistenceIncremental)
import Test.QuickCheck (checkCoverage, cover, elements, oneof, suchThat, (===))
import Test.QuickCheck.Gen (listOf)
import Test.QuickCheck.Monadic (monadicIO, monitor, pick, run)

spec :: Spec
spec :: Spec
spec = do
  FilePath -> Spec -> Spec
forall a. HasCallStack => FilePath -> SpecWith a -> SpecWith a
describe FilePath
"Persistence" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it FilePath
"can handle empty files" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
FilePath -> (FilePath -> m r) -> m r
withTempDir FilePath
"hydra-persistence" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
        let fp :: FilePath
fp = FilePath
tmpDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/data"
        FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS FilePath
fp ByteString
""
        Persistence{FromJSON Value => IO (Maybe Value)
load :: FromJSON Value => IO (Maybe Value)
$sel:load:Persistence :: forall a (m :: * -> *).
Persistence a m -> FromJSON a => m (Maybe a)
load} <- FilePath -> IO (Persistence Value IO)
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
FilePath -> m (Persistence a m)
createPersistence FilePath
fp
        IO (Maybe Value)
FromJSON Value => IO (Maybe Value)
load IO (Maybe Value) -> Maybe Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` (Maybe Value
forall a. Maybe a
Nothing :: Maybe Aeson.Value)

    FilePath -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it FilePath
"is consistent after save/load roundtrip" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
          Value
item <- Gen Value -> PropertyM IO Value
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen Value
genPersistenceItem
          Maybe Value
actualResult <- IO (Maybe Value) -> PropertyM IO (Maybe Value)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO (Maybe Value) -> PropertyM IO (Maybe Value))
-> IO (Maybe Value) -> PropertyM IO (Maybe Value)
forall a b. (a -> b) -> a -> b
$
            FilePath -> (FilePath -> IO (Maybe Value)) -> IO (Maybe Value)
forall (m :: * -> *) r.
MonadIO m =>
FilePath -> (FilePath -> m r) -> m r
withTempDir FilePath
"hydra-persistence" ((FilePath -> IO (Maybe Value)) -> IO (Maybe Value))
-> (FilePath -> IO (Maybe Value)) -> IO (Maybe Value)
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
              Persistence{ToJSON Value => Value -> IO ()
save :: ToJSON Value => Value -> IO ()
$sel:save:Persistence :: forall a (m :: * -> *). Persistence a m -> ToJSON a => a -> m ()
save, FromJSON Value => IO (Maybe Value)
$sel:load:Persistence :: forall a (m :: * -> *).
Persistence a m -> FromJSON a => m (Maybe a)
load :: FromJSON Value => IO (Maybe Value)
load} <- FilePath -> IO (Persistence Value IO)
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
FilePath -> m (Persistence a m)
createPersistence (FilePath -> IO (Persistence Value IO))
-> FilePath -> IO (Persistence Value IO)
forall a b. (a -> b) -> a -> b
$ FilePath
tmpDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/data"
              ToJSON Value => Value -> IO ()
Value -> IO ()
save Value
item
              IO (Maybe Value)
FromJSON Value => IO (Maybe Value)
load
          Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ Maybe Value
actualResult Maybe Value -> Maybe Value -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Value -> Maybe Value
forall a. a -> Maybe a
Just Value
item

  FilePath -> Spec -> Spec
forall a. HasCallStack => FilePath -> SpecWith a -> SpecWith a
describe FilePath
"PersistenceIncremental" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it FilePath
"can handle empty files" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
FilePath -> (FilePath -> m r) -> m r
withTempDir FilePath
"hydra-persistence" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
        let fp :: FilePath
fp = FilePath
tmpDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/data"
        FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBS FilePath
fp ByteString
""
        PersistenceIncremental{FromJSON Value => IO [Value]
loadAll :: FromJSON Value => IO [Value]
$sel:loadAll:PersistenceIncremental :: forall a (m :: * -> *).
PersistenceIncremental a m -> FromJSON a => m [a]
loadAll} <- FilePath -> IO (PersistenceIncremental Value IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
FilePath -> m (PersistenceIncremental a m)
createPersistenceIncremental FilePath
fp
        IO [Value]
FromJSON Value => IO [Value]
loadAll IO [Value] -> [Value] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` ([] :: [Aeson.Value])

    FilePath -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it FilePath
"is consistent after multiple append calls in presence of new-lines" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
          [Value]
items <- Gen [Value] -> PropertyM IO [Value]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen [Value] -> PropertyM IO [Value])
-> Gen [Value] -> PropertyM IO [Value]
forall a b. (a -> b) -> a -> b
$ Gen Value -> Gen [Value]
forall a. Gen a -> Gen [a]
listOf Gen Value
genPersistenceItem
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (Double -> Bool -> FilePath -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> FilePath -> prop -> Property
cover Double
1 ([Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
items) FilePath
"no items stored")
          (Property -> Property) -> PropertyM IO ()
forall (m :: * -> *).
Monad m =>
(Property -> Property) -> PropertyM m ()
monitor (Double -> Bool -> FilePath -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> FilePath -> prop -> Property
cover Double
10 ([Value] -> Bool
containsNewLine [Value]
items) FilePath
"some item contains a new line")

          [Value]
actualResult <- IO [Value] -> PropertyM IO [Value]
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (IO [Value] -> PropertyM IO [Value])
-> IO [Value] -> PropertyM IO [Value]
forall a b. (a -> b) -> a -> b
$
            FilePath -> (FilePath -> IO [Value]) -> IO [Value]
forall (m :: * -> *) r.
MonadIO m =>
FilePath -> (FilePath -> m r) -> m r
withTempDir FilePath
"hydra-persistence" ((FilePath -> IO [Value]) -> IO [Value])
-> (FilePath -> IO [Value]) -> IO [Value]
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
              PersistenceIncremental{FromJSON Value => IO [Value]
$sel:loadAll:PersistenceIncremental :: forall a (m :: * -> *).
PersistenceIncremental a m -> FromJSON a => m [a]
loadAll :: FromJSON Value => IO [Value]
loadAll, ToJSON Value => Value -> IO ()
append :: ToJSON Value => Value -> IO ()
$sel:append:PersistenceIncremental :: forall a (m :: * -> *).
PersistenceIncremental a m -> ToJSON a => a -> m ()
append} <- FilePath -> IO (PersistenceIncremental Value IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
FilePath -> m (PersistenceIncremental a m)
createPersistenceIncremental (FilePath -> IO (PersistenceIncremental Value IO))
-> FilePath -> IO (PersistenceIncremental Value IO)
forall a b. (a -> b) -> a -> b
$ FilePath
tmpDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/data"
              [Value] -> (Value -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Value]
items ToJSON Value => Value -> IO ()
Value -> IO ()
append
              IO [Value]
FromJSON Value => IO [Value]
loadAll
          Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ [Value]
actualResult [Value] -> [Value] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [Value]
items

    FilePath -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
FilePath -> a -> SpecWith (Arg a)
it FilePath
"it cannot load from a different thread once having started appending" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$
      PropertyM IO (IO ()) -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO (IO ()) -> Property)
-> PropertyM IO (IO ()) -> Property
forall a b. (a -> b) -> a -> b
$ do
        [Value]
items <- Gen [Value] -> PropertyM IO [Value]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen [Value] -> PropertyM IO [Value])
-> Gen [Value] -> PropertyM IO [Value]
forall a b. (a -> b) -> a -> b
$ Gen Value -> Gen [Value]
forall a. Gen a -> Gen [a]
listOf Gen Value
genPersistenceItem
        [Value]
moreItems <- Gen [Value] -> PropertyM IO [Value]
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick (Gen [Value] -> PropertyM IO [Value])
-> Gen [Value] -> PropertyM IO [Value]
forall a b. (a -> b) -> a -> b
$ Gen Value -> Gen [Value]
forall a. Gen a -> Gen [a]
listOf Gen Value
genPersistenceItem Gen [Value] -> ([Value] -> Bool) -> Gen [Value]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (Int -> Bool) -> ([Value] -> Int) -> [Value] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
        IO () -> PropertyM IO (IO ())
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> PropertyM IO (IO ())) -> IO () -> PropertyM IO (IO ())
forall a b. (a -> b) -> a -> b
$
          FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadIO m =>
FilePath -> (FilePath -> m r) -> m r
withTempDir FilePath
"hydra-persistence" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
            PersistenceIncremental{FromJSON Value => IO [Value]
$sel:loadAll:PersistenceIncremental :: forall a (m :: * -> *).
PersistenceIncremental a m -> FromJSON a => m [a]
loadAll :: FromJSON Value => IO [Value]
loadAll, ToJSON Value => Value -> IO ()
$sel:append:PersistenceIncremental :: forall a (m :: * -> *).
PersistenceIncremental a m -> ToJSON a => a -> m ()
append :: ToJSON Value => Value -> IO ()
append} <- FilePath -> IO (PersistenceIncremental Value IO)
forall a (m :: * -> *).
(MonadIO m, MonadThrow m, MonadSTM m, MonadThread m,
 MonadThrow (STM m)) =>
FilePath -> m (PersistenceIncremental a m)
createPersistenceIncremental (FilePath -> IO (PersistenceIncremental Value IO))
-> FilePath -> IO (PersistenceIncremental Value IO)
forall a b. (a -> b) -> a -> b
$ FilePath
tmpDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/data"
            [Value] -> (Value -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Value]
items ToJSON Value => Value -> IO ()
Value -> IO ()
append
            IO [Value]
FromJSON Value => IO [Value]
loadAll IO [Value] -> [Value] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Value]
items
            IO Any -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m ()
race_
              (IO [Value] -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO [Value] -> IO Any) -> IO [Value] -> IO Any
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.01 IO () -> IO [Value] -> IO [Value]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO [Value]
FromJSON Value => IO [Value]
loadAll)
              ([Value] -> (Value -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Value]
moreItems ((Value -> IO ()) -> IO ()) -> (Value -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Value
item -> ToJSON Value => Value -> IO ()
Value -> IO ()
append Value
item IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DiffTime -> IO ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.01)
              IO () -> Selector PersistenceException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
                IncorrectAccessException{} -> Bool
True
                PersistenceException
_ -> Bool
False

genPersistenceItem :: Gen Aeson.Value
genPersistenceItem :: Gen Value
genPersistenceItem =
  [Gen Value] -> Gen Value
forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ Value -> Gen Value
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
    , Text -> Value
String (Text -> Value) -> Gen Text -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
genSomeText
    ]

genSomeText :: Gen Text
genSomeText :: Gen Text
genSomeText = do
  let t :: FilePath
t = [Char
'A' .. Char
'z'] FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Char
'\n', Char
'\t', Char
'\r']
  FilePath -> Text
Text.pack (FilePath -> Text) -> Gen FilePath -> Gen Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Char -> Gen FilePath
forall a. Gen a -> Gen [a]
listOf (FilePath -> Gen Char
forall a. HasCallStack => [a] -> Gen a
elements FilePath
t)

containsNewLine :: [Aeson.Value] -> Bool
containsNewLine :: [Value] -> Bool
containsNewLine = \case
  [] -> Bool
False
  (Value
i : [Value]
is) -> case Value
i of
    String Text
t | Text
"\n" Text -> Text -> Bool
`Text.isInfixOf` Text
t -> Bool
True
    Value
_ -> [Value] -> Bool
containsNewLine [Value]
is