diff --git a/serokell-util.cabal b/serokell-util.cabal --- a/serokell-util.cabal +++ b/serokell-util.cabal @@ -1,5 +1,5 @@ name: serokell-util -version: 0.1.3.2 +version: 0.1.3.3 synopsis: General-purpose functions by Serokell homepage: https://github.com/serokell/serokell-util license: MIT @@ -109,6 +109,7 @@ Test.Serokell.Util.CommonSpec Test.Serokell.Util.ByteStringSpec Test.Serokell.Util.TextSpec + Test.Serokell.Util.VerifySpec Spec type: exitcode-stdio-1.0 build-depends: aeson >= 0.11.0.0 && < 1.0.0.0 diff --git a/src/Serokell/Arbitrary.hs b/src/Serokell/Arbitrary.hs --- a/src/Serokell/Arbitrary.hs +++ b/src/Serokell/Arbitrary.hs @@ -19,7 +19,12 @@ import Serokell.Data.Variant.Variant (Variant (..)) import qualified Serokell.Util.Base64 as S +import qualified Serokell.Util.Verify as V +------------------------------------------------------------------------------------------ +-- Serokell.Data.Variant +------------------------------------------------------------------------------------------ + instance Arbitrary S.JsonByteString where arbitrary = S.JsonByteString <$> (arbitrary :: Gen BS.ByteString) @@ -89,3 +94,13 @@ -- Lengths of keys and vals may not match and so we would get less -- constructors due to truncation, but we don't care. return $ VarMap $ H.fromList $ zip keys vals + +------------------------------------------------------------------------------------------ +-- Serokell.Util.Verify +------------------------------------------------------------------------------------------ + +instance Arbitrary V.VerificationRes where + arbitrary = oneof $ + [ pure V.VerSuccess + , V.VerFailure <$> arbitrary + ] diff --git a/src/Serokell/Util/Lens.hs b/src/Serokell/Util/Lens.hs --- a/src/Serokell/Util/Lens.hs +++ b/src/Serokell/Util/Lens.hs @@ -34,7 +34,15 @@ -- | Similar to `Wrapped`, but for `Monad`s. class Monad m => WrappedM m where type UnwrappedM m :: * -> * + _WrappedM :: L.Iso' (m a) (UnwrappedM m a) + _WrappedM = L.iso packM unpackM + + packM :: m a -> UnwrappedM m a + packM = L.view _WrappedM + + unpackM :: UnwrappedM m a -> m a + unpackM = L.view _UnwrappedM _UnwrappedM :: WrappedM m => L.Iso' (UnwrappedM m a) (m a) _UnwrappedM = L.from _WrappedM diff --git a/src/Serokell/Util/Verify.hs b/src/Serokell/Util/Verify.hs --- a/src/Serokell/Util/Verify.hs +++ b/src/Serokell/Util/Verify.hs @@ -35,7 +35,7 @@ data VerificationRes = VerSuccess | VerFailure ![T.Text] - deriving (Show) + deriving (Eq, Show) isVerSuccess :: VerificationRes -> Bool isVerSuccess VerSuccess = True diff --git a/test/Test/Serokell/Util/VerifySpec.hs b/test/Test/Serokell/Util/VerifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Serokell/Util/VerifySpec.hs @@ -0,0 +1,94 @@ +module Test.Serokell.Util.VerifySpec + ( spec + ) where + +import Test.Hspec (Expectation, Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Property, (===), (==>)) +import Test.QuickCheck.Instances () + +import Data.Semigroup ((<>)) +import qualified Data.Text as T (Text) + +import Serokell.Arbitrary () +import qualified Serokell.Util.Verify as V + +spec :: Spec +spec = + describe "Verify" $ do + describe "isVerSuccess" $ + prop description_isVerSuccess isVerSuccessWorks + describe "isVerSuccess" $ + prop description_isVerFailure isVerFailureWorks + describe "Monoid VerificationRes" $ + prop description_verificationResIsMonoid verificationResIsMonoid + describe "verifyGeneric" $ do + it "verifyGeneric of an empty string always succeeds" + (V.verifyGeneric [] `shouldBe` V.VerSuccess) + prop description_verifyGeneric verifyGenericWorks + prop description_verifyGenericMessageOrder verifyGenericMessageOrder + where + description_isVerSuccess = + "A successful verification should yield True, and an unsuccessful one should\ + \ yield False" + description_isVerFailure = + "An unsuccessful verification should yield True, and an unsuccessful one should\ + \ yield False" + description_verificationResIsMonoid = + "The set of verification results with the concatenation operation defined in the\ + \ Serokell.Util.Verify module forms a monoid" + description_verifyGeneric = + "A list of predicates with a single failure yields a failed verification, and a\ + \ list of predicates with no failures yields a successful verification" + description_verifyGenericMessageOrder = + "Error messages in a predicate list are taken from left to right" + +isVerSuccessWorks :: V.VerificationRes -> Expectation +isVerSuccessWorks v = case v of + V.VerSuccess -> V.isVerSuccess v `shouldBe` True + V.VerFailure _ -> V.isVerSuccess v `shouldBe` False + +-- | The property +-- `isVerFailure = not . isVerSuccess` +-- should hold for all v in VerificationRes +isVerFailureWorks :: V.VerificationRes -> Property +isVerFailureWorks v = (not . V.isVerSuccess $ v) === V.isVerFailure v + +verificationResIsMonoid + :: V.VerificationRes + -> V.VerificationRes + -> V.VerificationRes + -> Bool +verificationResIsMonoid v1 v2 v3 = + let isAssociative = + let assoc1 = (v1 <> v2) <> v3 + assoc2 = v1 <> (v2 <> v3) + in assoc1 == assoc2 + hasIdentity = + let id1 = mempty <> v1 + id2 = v1 <> mempty + in (v1 == id1) && (v1 == id2) + in isAssociative && hasIdentity + +-- | The function `verifyGeneric` must have the following properties +-- (any (not . fst) l :: [(Bool, a)]) iff (isVerFailure . verifyGeneric) l +-- (all (identity . fst) l :: [(Bool, a)]) iff (isVerSuccess . verifyGeneric) l + +verifyGenericWorks :: [(Bool, T.Text)] -> Bool +verifyGenericWorks l = + let someFailure = any (not . fst) l + allSuccess = not someFailure + in (someFailure == (V.isVerFailure . V.verifyGeneric $ l)) && + (allSuccess == (V.isVerSuccess . V.verifyGeneric $ l)) + +-- | This property checks that the error messages in a list of predicates are collected +-- from left to right. + +verifyGenericMessageOrder :: [(Bool, T.Text)] -> Property +verifyGenericMessageOrder l = + let someFailure = any (not . fst) l + msgList = foldr (\(b, err) accList -> + if not b then err : accList + else accList) [] l + in someFailure ==> + ((V.VerFailure msgList) == V.verifyGeneric l)