urbit/pkg/hs-urbit/test/LogTests.hs

module LogTests (tests) where

import Data.Acquire
import Test.QuickCheck       hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import UrbitPrelude
import Vere.Log
import Vere.Pier.Types
import Data.Conduit
import Data.Conduit.List

import Control.Concurrent (threadDelay, runInBoundThread)
import Data.LargeWord     (LargeKey(..))
import GHC.Natural        (Natural)

import qualified Vere.Log as Log


-- Utils -----------------------------------------------------------------------

withTestDir :: (FilePath -> IO a) -> IO a
withTestDir = withTempDirectory "./" ".testlog."

data NotEqual = NotEqual String String
  deriving (Eq, Ord, Show)

instance Exception NotEqual where

assertEqual :: (Show a, Eq a) => a -> a -> IO ()
assertEqual x y = do
    unless (x == y) $
        throwIO (NotEqual (show x) (show y))


-- Database Operations ---------------------------------------------------------

data Db = Db LogIdentity [Atom]
  deriving (Eq, Ord, Show)

addEvents :: Db -> [Atom] -> Db
addEvents (Db id evs) new = Db id (evs <> new)

readDb :: EventLog -> IO Db
readDb log = do
    events <- runConduit (streamEvents log 1 .| consume)
    pure $ Db (Log.identity log) events

withDb :: FilePath -> Db -> (EventLog -> IO a) -> IO a
withDb dir (Db dId dEvs) act = do
    with (Log.new dir dId) $ \log -> do
        Log.appendEvents log (fromList dEvs)
        act log

--------------------------------------------------------------------------------

tryReadIdentity :: Property
tryReadIdentity = forAll arbitrary (ioProperty . runTest)
  where
    runTest :: LogIdentity -> IO Bool
    runTest ident = do
        runInBoundThread $
            withTestDir $ \dir -> do
                with (Log.new dir ident) $ \log ->
                    assertEqual ident (Log.identity log)
                with (Log.existing dir) $ \log ->
                    assertEqual ident (Log.identity log)
                with (Log.existing dir) $ \log ->
                    assertEqual ident (Log.identity log)
        pure True

tryReadDatabase :: Property
tryReadDatabase = forAll arbitrary (ioProperty . runTest)
  where
    runTest :: Db -> IO Bool
    runTest db = do
        runInBoundThread $
            withTestDir $ \dir -> do
                withDb dir db $ \log -> do
                    readDb log >>= assertEqual db
                with (Log.existing dir) $ \log -> do
                    readDb log >>= assertEqual db
                with (Log.existing dir) $ \log -> do
                    readDb log >>= assertEqual db
                    readDb log >>= assertEqual db
        pure True

tryAppend :: Property
tryAppend = forAll arbitrary (ioProperty . runTest)
  where
    runTest :: ([Atom], Db) -> IO Bool
    runTest (extra, db) = do
        runInBoundThread $
            withTestDir $ \dir -> do
                db' <- pure (addEvents db extra)
                withDb dir db $ \log -> do
                    readDb log >>= assertEqual db
                    Log.appendEvents log (fromList extra)
                    readDb log >>= assertEqual db'
                with (Log.existing dir) $ \log -> do
                    readDb log >>= assertEqual db'
        pure True

readAtom :: FilePath -> IO Atom
readAtom path = view (from atomBytes) <$> readFile path

tryAppendHuge :: Property
tryAppendHuge = forAll arbitrary (ioProperty . runTest)
  where
    runTest :: ([Atom], Db) -> IO Bool
    runTest (extra, db) = do
        runInBoundThread $ do
            extra <- do b <- readAtom "/home/benjamin/r/urbit/bin/brass.pill"
                        pure (extra <> [b] <> extra)
            withTestDir $ \dir -> do
                db' <- pure (addEvents db extra)
                withDb dir db $ \log -> do
                    readDb log >>= assertEqual db
                    Log.appendEvents log (fromList extra)
                    readDb log >>= assertEqual db'
                with (Log.existing dir) $ \log -> do
                    readDb log >>= assertEqual db'
        pure True


tests :: TestTree
tests =
  testGroup "Log"
    [ localOption (QuickCheckTests 10) $
          testProperty "Read/Write Log Identity" $
              tryReadIdentity
    , localOption (QuickCheckTests 10) $
          testProperty "Read/Write Database" $
              tryReadDatabase
    , localOption (QuickCheckTests 10) $
          testProperty "Append Random Events" $
              tryAppend
    , localOption (QuickCheckTests 1) $
          testProperty "Append Huge Events" $
              tryAppendHuge
    ]


-- Generate Arbitrary Values ---------------------------------------------------

arb :: Arbitrary a => Gen a
arb = arbitrary

instance Arbitrary Natural where
  arbitrary = fromInteger . abs <$> arbitrary

instance (Arbitrary a, Arbitrary b) => Arbitrary (LargeKey a b) where
  arbitrary = LargeKey <$> arb <*> arb

instance Arbitrary Ship where
  arbitrary = Ship <$> arb

instance Arbitrary Db where
  arbitrary = Db <$> arbitrary <*> arbitrary

instance Arbitrary LogIdentity where
  arbitrary = LogIdentity <$> arb <*> arb <*> arb