Golden.hs

{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Database.LSMTree.Internal.Snapshot.Codec.Golden (
    tests
  , EnumGolden (..)
  , Annotation
  ) where

import           Codec.CBOR.Read (deserialiseFromBytes)
import           Codec.CBOR.Write (toLazyByteString)
import           Control.Monad (when)
import           Control.Monad.Class.MonadThrow (Exception (displayException))
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Set as Set
import           Data.Typeable
import qualified Data.Vector as V
import           Database.LSMTree.Internal.Config (BloomFilterAlloc (..),
                     DiskCachePolicy (..), FencePointerIndexType (..),
                     MergeBatchSize (..), MergePolicy (..), MergeSchedule (..),
                     SizeRatio (..), TableConfig (..), WriteBufferAlloc (..))
import           Database.LSMTree.Internal.MergeSchedule
                     (MergePolicyForLevel (..), NominalCredits (..),
                     NominalDebt (..))
import           Database.LSMTree.Internal.MergingRun as MR
import           Database.LSMTree.Internal.RunBuilder (IndexType (..),
                     RunBloomFilterAlloc (..), RunDataCaching (..))
import           Database.LSMTree.Internal.RunNumber (RunNumber (..))
import           Database.LSMTree.Internal.Snapshot
import           Database.LSMTree.Internal.Snapshot.Codec
import           Paths_lsm_tree
import qualified System.Directory as Dir
import           System.FilePath
import qualified System.FS.API as FS
import           System.FS.API.Types (MountPoint (..))
import           System.FS.IO (ioHasFS)
import           System.IO.Unsafe
import           Test.Database.LSMTree.Internal.Snapshot.Codec ()
import           Test.QuickCheck (Property, counterexample, ioProperty, once,
                     (.&&.))
import qualified Test.Tasty as Tasty
import           Test.Tasty (TestTree, testGroup)
import qualified Test.Tasty.Golden as Au
import           Test.Tasty.HUnit (Assertion, assertEqual, assertFailure,
                     testCase)
import           Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests =
    testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec.Golden" [
        handleOutputFiles $
        testGroup "Generate golden files" $
            concat (forallSnapshotTypes snapshotCodecGoldenTest) ++
          [ testProperty "prop_noUnexpectedOrMissingGoldenFiles" prop_noUnexpectedOrMissingGoldenFiles
          ]
      , testGroup "Backwards compatibility" [
            testCase "test_compatTableConfigV0" test_compatTableConfigV0
          , testCase "test_compatSnapLevelV1" test_compatSnapLevelV1
          ]
      ]

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

-- | The location of the golden file data directory relative to the project root.
goldenDataFilePath :: FilePath
goldenDataFilePath = unsafePerformIO getDataDir </> "snapshot-codec"

goldenDataMountPoint :: MountPoint
goldenDataMountPoint = MountPoint goldenDataFilePath

-- | Delete output files on test-case success.
-- Change the option here if this is undesirable.
handleOutputFiles :: TestTree -> TestTree
handleOutputFiles = Tasty.localOption Au.OnPass

{-------------------------------------------------------------------------------
  Golden tests
-------------------------------------------------------------------------------}

-- | Compare the serialization of snapshot metadata with a known reference file.
snapshotCodecGoldenTest ::
     forall a. (Typeable a, EnumGolden a, Encode a)
  => Proxy a
  -> [TestTree]
snapshotCodecGoldenTest proxy = [
      go annotation datum
    | (annotation, datum) <- enumGoldenAnnotated' proxy v
    ]
  where
    v = currentSnapshotVersion
    go ann datum =
      let outputFilePath = goldenDataFilePath </> filePathOutput proxy ann v
          goldenFilePath = goldenDataFilePath </> filePathGolden proxy ann v

          -- IO actions
          removeIfExists :: FilePath -> IO ()
          removeIfExists fp =
              Dir.doesFileExist fp >>= (`when` (Dir.removeFile fp))
          outputAction :: IO ()
          outputAction = do
            -- Ensure that if the output file already exists, we remove it and
            -- re-write out the serialized data. This ensures that there are no
            -- false-positives, false-negatives, or irrelevant I/O exceptions.
            removeIfExists outputFilePath
            BSL.writeFile outputFilePath . toLazyByteString $ encode datum

      in  Au.goldenVsFile (nameGolden proxy ann v) goldenFilePath outputFilePath outputAction

-- | Check that are no missing or unexpected files in the output directory
prop_noUnexpectedOrMissingGoldenFiles :: Property
prop_noUnexpectedOrMissingGoldenFiles = once $ ioProperty $ do
    let expectedFiles = Set.fromList $ concat $ forallSnapshotTypes $ \p ->
          concat [
              filePathsGolden p v
            | v <- allCompatibleSnapshotVersions
            ]

    let hfs = ioHasFS goldenDataMountPoint
    actualDirectoryEntries <- FS.listDirectory hfs (FS.mkFsPath [])

    let missingFiles = expectedFiles Set.\\ actualDirectoryEntries
        propMissing =
            counterexample ("Missing expected files: " ++ show missingFiles)
          $ counterexample ("Run the golden tests to regenerate the missing files")
          $ (Set.null missingFiles)

    let unexpectedFiles = actualDirectoryEntries Set.\\ expectedFiles
        propUnexpected =
            counterexample ("Found unexpected files: " ++ show unexpectedFiles)
          $ counterexample ("Delete the unexpected files manually from " ++ goldenDataFilePath)
            (Set.null unexpectedFiles)

    pure $ propMissing .&&. propUnexpected

{-------------------------------------------------------------------------------
  Backwards compatibility tests
-------------------------------------------------------------------------------}

test_compatTableConfigV0 :: Assertion
test_compatTableConfigV0 =
    assertGoldenFileDecodesTo (Proxy @TableConfig) "A" V0 $
      TableConfig {
          confMergePolicy = singGolden V0
        , confMergeSchedule = singGolden V0
        , confSizeRatio = singGolden V0
        , confWriteBufferAlloc = singGolden V0
        , confBloomFilterAlloc = singGolden V0
        , confFencePointerIndex = singGolden V0
        , confDiskCachePolicy = singGolden V0
          -- MergeBatchSize not included in V0, decoder uses WriteBufferAlloc
        , confMergeBatchSize = MergeBatchSize magicNumber2
        }

test_compatSnapLevelV1 :: Assertion
test_compatSnapLevelV1 =
    assertGoldenFileDecodesTo (Proxy @(SnapLevel SnapshotRun)) "A" V1 $
      -- Until V2, there was only a single constructor, so there was no tag
      -- in the serialisation format to distinguish constructors.
      SnapLevel (singGolden V1) (singGolden V1)

-- | For types that changed their snapshot format between versions, we should
-- also test that we can in fact still decode the old format.
assertGoldenFileDecodesTo ::
     (DecodeVersioned a, Eq a, Show a, Typeable a)
  => Proxy a
  -> String
  -> SnapshotVersion
  -> a
  -> Assertion
assertGoldenFileDecodesTo proxy ann v expected = do
    let fp = goldenDataFilePath </> filePathGolden proxy ann v
    lbs <- BSL.readFile fp
    case deserialiseFromBytes (decodeVersioned v) lbs of
      Left err ->
        assertFailure $ "Error decoding " ++ fp ++ ": " ++ displayException err
      Right (_, decoded) ->
        assertEqual "" expected decoded

{-------------------------------------------------------------------------------
  Mapping
-------------------------------------------------------------------------------}

type Constraints a = (Typeable a, Encode a, EnumGolden a)

-- | Do something for all snapshot types and collect the results
forallSnapshotTypes ::
     (forall a. Constraints a => Proxy a -> b)
  -> [b]
forallSnapshotTypes f = [
      -- SnapshotMetaData
      f (Proxy @SnapshotMetaData)
    , f (Proxy @SnapshotLabel)
    , f (Proxy @SnapshotRun)
      -- TableConfig
    , f (Proxy @TableConfig)
    , f (Proxy @MergePolicy)
    , f (Proxy @SizeRatio)
    , f (Proxy @WriteBufferAlloc)
    , f (Proxy @BloomFilterAlloc)
    , f (Proxy @FencePointerIndexType)
    , f (Proxy @DiskCachePolicy)
    , f (Proxy @MergeSchedule)
    , f (Proxy @MergeBatchSize)
      -- SnapLevels
    , f (Proxy @(SnapLevels SnapshotRun))
    , f (Proxy @(SnapLevel SnapshotRun))
    , f (Proxy @(V.Vector SnapshotRun))
    , f (Proxy @RunNumber)
    , f (Proxy @(SnapIncomingRun SnapshotRun))
    , f (Proxy @MergePolicyForLevel)
    , f (Proxy @RunDataCaching)
    , f (Proxy @RunBloomFilterAlloc)
    , f (Proxy @IndexType)
    , f (Proxy @RunParams)
    , f (Proxy @(SnapMergingRun LevelMergeType SnapshotRun))
    , f (Proxy @MergeDebt)
    , f (Proxy @MergeCredits)
    , f (Proxy @NominalDebt)
    , f (Proxy @NominalCredits)
    , f (Proxy @LevelMergeType)
    , f (Proxy @TreeMergeType)
    , f (Proxy @(SnapMergingTree SnapshotRun))
    , f (Proxy @(SnapMergingTreeState SnapshotRun))
    , f (Proxy @(SnapMergingRun TreeMergeType SnapshotRun))
    , f (Proxy @(SnapPendingMerge SnapshotRun))
    , f (Proxy @(SnapPreExistingRun SnapshotRun))
    ]

{-------------------------------------------------------------------------------
  Enumeration class
-------------------------------------------------------------------------------}

-- | Enumerate values of type @a@ for golden tests
--
-- To prevent combinatorial explosion, the enumeration should generally be
-- /shallow/: the different constructors for type @a@ should be enumerated
-- without recursively enumerating the constructors' fields. For example,
-- enumerating @Maybe Int@ should give us something like:
--
-- > enumGolden @(Maybe Int) = [ Just 17, Nothing ]
--
-- This is generally a suitable approach, since the snapshot encodings do not
-- encode types differently depending on values in the constructor fields.
--
-- Example (recursive) instances that prevent combinatorial explosion:
--
-- @
--  instance EnumGolden a => EnumGolden (Maybe a) where
--    enumGolden = [ Just (singGolden @a), Nothing ]
--  instance EnumGolden Int where
--    enumGolden = [17, -72] -- singGolden = 17
-- @
--
-- If there are encoders that do require more elaborate (recursive)
-- enumerations, then it is okay to deviate from shallow enumerations, but take
-- care not to explode the combinatorics ;)
class EnumGolden a where
  {-# MINIMAL enumGolden | enumGoldenAnnotated | singGolden #-}

  -- | Enumerated values. The enumeration should be /shallow/.
  --
  -- The default implementation is to return a singleton list containing
  -- 'singGolden'.
  enumGolden :: SnapshotVersion -> [a]
  enumGolden v = [ singGolden v ]

  -- | Enumerated values with an annotation for naming purposes. The enumeration
  -- should be /shallow/, and the annotations should be unique.
  --
  -- The default implementation is to annotate 'enumGolden' with capital letters
  -- starting with @\'A\'@.
  enumGoldenAnnotated :: SnapshotVersion -> [(Annotation, a)]
  enumGoldenAnnotated v = zip [[c] | c <- ['A' .. 'Z']] (enumGolden v)

  -- | A singleton enumerated value. This is mainly useful for superclass
  -- instances.
  --
  -- The default implementation is to take the 'head' of 'enumGoldenAnnotated'.
  singGolden :: SnapshotVersion -> a
  singGolden v = snd $ head (enumGoldenAnnotated v)

type Annotation = String

enumGoldenAnnotated' ::
     EnumGolden a
  => Proxy a
  -> SnapshotVersion
  -> [(Annotation, a)]
enumGoldenAnnotated' _ v = enumGoldenAnnotated v

{-------------------------------------------------------------------------------
  Enumeration class: names and file paths
-------------------------------------------------------------------------------}

nameGolden :: Typeable a => Proxy a -> Annotation -> SnapshotVersion -> String
nameGolden p ann v = show v ++ "." ++ map spaceToUnderscore (show $ typeRep p) ++ "." ++ ann

spaceToUnderscore :: Char -> Char
spaceToUnderscore ' ' = '_'
spaceToUnderscore c   = c

filePathsGolden ::
     (EnumGolden a, Typeable a)
  => Proxy a
  -> SnapshotVersion
  -> [String]
filePathsGolden p v = [
      filePathGolden p annotation v
    | (annotation, _) <- enumGoldenAnnotated' p v
    ]

filePathOutput :: Typeable a => Proxy a -> String -> SnapshotVersion -> String
filePathOutput p ann v = nameGolden p ann v ++ ".snapshot"

filePathGolden :: Typeable a => Proxy a -> String -> SnapshotVersion -> String
filePathGolden p ann v = nameGolden p ann v ++ ".snapshot.golden"

{-------------------------------------------------------------------------------
  Enumeration class: instances
-------------------------------------------------------------------------------}

instance EnumGolden SnapshotMetaData where
  singGolden v = SnapshotMetaData (singGolden v) (singGolden v) (singGolden v)
                                  (singGolden v) (singGolden v)
    where
      _coveredAllCases = \case
        SnapshotMetaData{} -> ()

instance EnumGolden SnapshotLabel where
  enumGolden _v = [
        SnapshotLabel "UserProvidedLabel"
      , SnapshotLabel ""
      ]
    where
      _coveredAllCases = \case
        SnapshotLabel{} -> ()

instance EnumGolden TableConfig where
  singGolden v = TableConfig (singGolden v) (singGolden v) (singGolden v)
                             (singGolden v) (singGolden v) (singGolden v)
                             (singGolden v) (singGolden v)
    where
      _coveredAllCases = \case
        TableConfig{} -> ()

instance EnumGolden MergePolicy where
  singGolden _v = LazyLevelling
    where
      _coveredAllCases = \case
        LazyLevelling{} -> ()


instance EnumGolden SizeRatio where
  singGolden _v = Four
    where
      _coveredAllCases = \case
        Four{} -> ()

instance EnumGolden WriteBufferAlloc where
  singGolden _v = AllocNumEntries magicNumber2
    where
      _coveredAllCases = \case
        AllocNumEntries{} -> ()

instance EnumGolden BloomFilterAlloc where
  enumGolden _v = [ AllocFixed magicNumber3, AllocRequestFPR pi ]
    where
      _coveredAllCases = \case
        AllocFixed{} -> ()
        AllocRequestFPR{} -> ()

instance EnumGolden FencePointerIndexType where
  enumGolden _v = [ CompactIndex, OrdinaryIndex ]
    where
      _coveredAllCases = \case
        CompactIndex{} -> ()
        OrdinaryIndex{} -> ()

instance EnumGolden DiskCachePolicy where
  enumGolden _v = [ DiskCacheAll, DiskCacheLevelOneTo magicNumber3, DiskCacheNone ]
    where
      _coveredAllCases = \case
        DiskCacheAll{} -> ()
        DiskCacheLevelOneTo{} -> ()
        DiskCacheNone{} -> ()

instance EnumGolden MergeSchedule where
  enumGolden _v = [ OneShot, Incremental ]
    where
      _coveredAllCases = \case
        OneShot{} -> ()
        Incremental{} -> ()

instance EnumGolden MergeBatchSize where
  enumGolden v
    | v >= V1   = map MergeBatchSize [ 1, 1000 ]
    | otherwise = []

instance EnumGolden (SnapLevels SnapshotRun) where
  singGolden v = SnapLevels (singGolden v)
    where
      _coveredAllCases = \case
        SnapLevels{} -> ()

instance EnumGolden (SnapLevel SnapshotRun) where
  enumGolden v = [
        SnapLevel (singGolden v) (singGolden v)
      ] ++ [
        SnapEmptyLevel | v >= V2
      ]
    where
      _coveredAllCases = \case
        SnapEmptyLevel{} -> ()
        SnapLevel{} -> ()

instance EnumGolden (SnapIncomingRun SnapshotRun) where
  enumGolden v = [
        SnapIncomingMergingRun (singGolden v) (singGolden v) (singGolden v)
                               (singGolden v)
      , SnapIncomingSingleRun (singGolden v)
      ]
    where
      _coveredAllCases = \case
        SnapIncomingMergingRun{} -> ()
        SnapIncomingSingleRun{} -> ()

instance EnumGolden MergePolicyForLevel where
  enumGolden _v = [ LevelTiering, LevelLevelling ]
    where
      _coveredAllCases = \case
        LevelTiering -> ()
        LevelLevelling -> ()

instance EnumGolden LevelMergeType where
  enumGolden _v = [ MergeMidLevel, MergeLastLevel ]
    where
      _coveredAllCases = \case
        MergeMidLevel{} -> ()
        MergeLastLevel{} -> ()

instance EnumGolden (SnapMergingTree SnapshotRun) where
  singGolden v = SnapMergingTree (singGolden v)
    where
      _coveredAllCases = \case
        SnapMergingTree{} -> ()

instance EnumGolden (SnapMergingTreeState SnapshotRun) where
  enumGolden v = [
        SnapCompletedTreeMerge (singGolden v)
      , SnapPendingTreeMerge (singGolden v)
      , SnapOngoingTreeMerge (singGolden v)
      ]
    where
      _coveredAllCases = \case
        SnapCompletedTreeMerge{} -> ()
        SnapPendingTreeMerge{} -> ()
        SnapOngoingTreeMerge{} -> ()

instance EnumGolden (SnapPendingMerge SnapshotRun) where
  enumGolden v = [
        SnapPendingLevelMerge (singGolden v) (singGolden v)
      , SnapPendingUnionMerge (singGolden v)
      ]
    where
      _coveredAllCases = \case
        SnapPendingLevelMerge{} -> ()
        SnapPendingUnionMerge{} -> ()

instance EnumGolden (SnapPreExistingRun SnapshotRun) where
  enumGolden v = [
        SnapPreExistingRun (singGolden v)
      , SnapPreExistingMergingRun (singGolden v)
      ]
    where
      _coveredAllCases = \case
        SnapPreExistingRun{} -> ()
        SnapPreExistingMergingRun{} -> ()

instance EnumGolden TreeMergeType where
  enumGolden _v = [ MergeLevel, MergeUnion ]
    where
      _coveredAllCases = \case
        MergeLevel{} -> ()
        MergeUnion{} -> ()

instance EnumGolden a => EnumGolden (Maybe a) where
  enumGolden v = [ Just (singGolden v), Nothing ]
    where
      _coveredAllCases = \case
        Just{} -> ()
        Nothing{} -> ()

instance EnumGolden a => EnumGolden (V.Vector a) where
  enumGolden v = [
      V.fromList [ singGolden v, singGolden v ]
    , mempty
    , V.fromList [ singGolden v ]
    ]

instance EnumGolden a => EnumGolden [a] where
  enumGolden v = [
      [ singGolden v, singGolden v ]
    , []
    , [ singGolden v]
    ]

instance EnumGolden RunParams where
  singGolden v = RunParams (singGolden v) (singGolden v) (singGolden v)
    where
      _coveredAllCases = \case
        RunParams{} -> ()

instance EnumGolden t => EnumGolden (SnapMergingRun t SnapshotRun) where
  enumGolden v = [
        SnapCompletedMerge (singGolden v) (singGolden v)
      , SnapOngoingMerge (singGolden v) (singGolden v) (singGolden v)
                         (singGolden v)
      ]
    where
      _coveredAllCases = \case
        SnapCompletedMerge{} -> ()
        SnapOngoingMerge{} -> ()

instance EnumGolden RunBloomFilterAlloc where
  enumGolden _v = [
        RunAllocFixed magicNumber3
      , RunAllocRequestFPR pi
      ]
    where
      _coveredAllCases = \case
        RunAllocFixed{} -> ()
        RunAllocRequestFPR{} -> ()

instance EnumGolden RunNumber where
  singGolden _v = RunNumber magicNumber3
    where
      _coveredAllCases = \case
        RunNumber{} -> ()

instance EnumGolden IndexType where
  enumGolden _v = [
        Compact
      , Ordinary
      ]
    where
      _coveredAllCases = \case
        Compact{} -> ()
        Ordinary{} -> ()

instance EnumGolden RunDataCaching where
  enumGolden _v = [
        CacheRunData
      , NoCacheRunData
      ]
    where
      _coveredAllCases = \case
        CacheRunData{} -> ()
        NoCacheRunData{} -> ()

instance EnumGolden SnapshotRun where
  singGolden v = SnapshotRun (singGolden v) (singGolden v) (singGolden v)
    where
      _coveredAllCases = \case
        SnapshotRun{} -> ()

instance EnumGolden MergeDebt where
  singGolden _v = MergeDebt magicNumber2
    where
      _coveredAllCases = \case
        MergeDebt{} -> ()

instance EnumGolden MergeCredits where
  singGolden _v = MergeCredits magicNumber2
    where
      _coveredAllCases = \case
        MergeCredits{} -> ()

instance EnumGolden NominalDebt where
  singGolden _v = NominalDebt magicNumber2
    where
      _coveredAllCases = \case
        NominalDebt{} -> ()

instance EnumGolden NominalCredits where
  singGolden _v = NominalCredits magicNumber1
    where
      _coveredAllCases = \case
        NominalCredits{} -> ()

  -- Randomly chosen numbers
magicNumber1, magicNumber2, magicNumber3 :: Enum e => e
magicNumber1 = toEnum 42
magicNumber2 = toEnum 88
magicNumber3 = toEnum 1024