ValueSpec.hs

{-# LANGUAGE TypeApplications #-}

module Data.Mergeful.ValueSpec
  ( spec,
  )
where

import Data.GenValidity.Mergeful.Value ()
import Data.Mergeful.Timed
import Data.Mergeful.Value
import Test.Hspec
import Test.QuickCheck
import Test.Validity
import Test.Validity.Aeson

{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

forAllSubsequent :: Testable prop => ((ServerTime, ServerTime) -> prop) -> Property
forAllSubsequent func =
  forAllValid $ \st ->
    forAllShrink (genValid `suchThat` (> st)) (filter (> st) . shrinkValid) $ \st' -> func (st, st')

spec :: Spec
spec = do
  genValidSpec @(ClientValue Int)
  jsonSpec @(ClientValue Int)
  genValidSpec @(ServerValue Int)
  jsonSpec @(ServerValue Int)
  genValidSpec @(ValueSyncRequest Int)
  jsonSpec @(ValueSyncRequest Int)
  genValidSpec @(ValueSyncResponse Int)
  jsonSpec @(ValueSyncResponse Int)
  describe "makeValueSyncRequest" $
    it "produces valid requests" $
      producesValid (makeValueSyncRequest @Int)
  describe "mergeValueSyncResponseRaw" $
    it "produces valid client stores" $
      producesValid2 (mergeValueSyncResponseRaw @Int)
  describe "mergeValueSyncResponseIgnoreProblems" $
    it "produces valid client stores" $
      producesValid2 (mergeValueSyncResponseIgnoreProblems @Int)
  describe "processServerValueSync" $ do
    it "produces valid responses and stores" $ producesValid2 (processServerValueSync @Int)
    it "makes no changes if the sync request reflects the state of the server" $
      forAllValid $
        \i ->
          forAllValid $ \st -> do
            let store1 = ServerValue $ Timed i st
                req = ValueSyncRequestKnown st
            let (resp, store2) = processServerValueSync @Int store1 req
            store2 `shouldBe` store1
            resp `shouldBe` ValueSyncResponseInSync
    describe "Client changes" $
      it "changes the item that the client tells the server to change" $
        forAllValid $
          \i ->
            forAllValid $ \j ->
              forAllValid $ \st -> do
                let store1 = ServerValue (Timed i st)
                    req = ValueSyncRequestKnownButChanged (Timed j st)
                let (resp, store2) = processServerValueSync @Int store1 req
                let time = incrementServerTime st
                store2 `shouldBe` ServerValue (Timed j time)
                resp `shouldBe` ValueSyncResponseClientChanged time
    describe "Server changes" $
      it "tells the client that there is a modified item at the server side" $
        forAllValid $
          \i ->
            forAllSubsequent $ \(st, st') -> do
              let store1 = ServerValue (Timed i st')
                  req = ValueSyncRequestKnown st
              let (resp, store2) = processServerValueSync @Int store1 req
              store2 `shouldBe` store1
              resp `shouldBe` ValueSyncResponseServerChanged (Timed i st')
    describe "Conflicts" $
      it "notices a conflict if the client and server are trying to sync different items" $
        forAllValid $
          \i ->
            forAllValid $ \j ->
              forAllSubsequent $ \(st, st') -> do
                let store1 = ServerValue (Timed i st')
                    req = ValueSyncRequestKnownButChanged (Timed j st)
                let (resp, store2) = processServerValueSync @Int store1 req
                store2 `shouldBe` store1
                resp `shouldBe` ValueSyncResponseConflict (Timed i st')
  describe "syncing" $ do
    it "succesfully syncs a modification across to a second client" $
      forAllValid $
        \time1 ->
          forAllValid $ \i ->
            forAllValid $ \j -> do
              let cAstore1 = ClientValue (Timed i time1) NotChanged
              -- Client B had synced that same item, but has since modified it
              let cBstore1 = ClientValue (Timed j time1) Changed
              -- The server is has the item that both clients had before
              let sstore1 = ServerValue (Timed i time1)
              -- Client B makes sync request 1
              let req1 = makeValueSyncRequest cBstore1
              -- The server processes sync request 1
              let (resp1, sstore2) = processServerValueSync @Int sstore1 req1
              let time2 = incrementServerTime time1
              resp1 `shouldBe` ValueSyncResponseClientChanged time2
              sstore2 `shouldBe` ServerValue (Timed j time2)
              -- Client B merges the response
              let cBstore2 = mergeValueSyncResponseIgnoreProblems cBstore1 resp1
              cBstore2 `shouldBe` ClientValue (Timed j time2) NotChanged
              -- Client A makes sync request 2
              let req2 = makeValueSyncRequest cAstore1
              -- The server processes sync request 2
              let (resp2, sstore3) = processServerValueSync sstore2 req2
              resp2 `shouldBe` ValueSyncResponseServerChanged (Timed j time2)
              sstore3 `shouldBe` ServerValue (Timed j time2)
              -- Client A merges the response
              let cAstore2 = mergeValueSyncResponseIgnoreProblems cAstore1 resp2
              cAstore2 `shouldBe` ClientValue (Timed j time2) NotChanged
              -- Client A and Client B now have the same store
              cAstore2 `shouldBe` cBstore2
    it "is idempotent with one client" $
      forAllValid $
        \cstore1 ->
          forAllValid $ \sstore1 -> do
            let req1 = makeValueSyncRequest (cstore1 :: ClientValue Int)
                (resp1, sstore2) = processServerValueSync sstore1 req1
                cstore2 = mergeValueSyncResponseIgnoreProblems cstore1 resp1
                req2 = makeValueSyncRequest cstore2
                (resp2, sstore3) = processServerValueSync sstore2 req2
                cstore3 = mergeValueSyncResponseIgnoreProblems cstore2 resp2
            cstore2 `shouldBe` cstore3
            sstore2 `shouldBe` sstore3