data-validation 0.1.0.2 → 0.1.2.0

raw patch · 6 files changed

+242/−21 lines, 6 filesdep +regex-tdfadep ~basedep ~containersdep ~template-haskellnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-tdfa

Dependency ranges changed: base, containers, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• data-validation.cabal +17/−7
• examples/Examples/Data/ComplexTypes.hs +55/−0
• examples/Examples/Data/Primitives.hs +73/−0
• src/Data/Validation.hs +43/−14
• test/Data/ValidationSpec.hs +43/−0

@@ -1,5 +1,16 @@ # Revision history for data-validation
 
+## 0.1.2.0 -- 2020-11-10
+
+* Minor changes to haddocks.
+* Added conditional requirement helper functions.
+* Expanded example and tests.
+
+## 0.1.1.0 -- 2020-10-29
+
+* Added helper for flattening a list of proofs.
+* Loosen package version requirements after testing with GHC 8.8.
+
 ## 0.1.0.2 -- 2020-09-09
 
 * Loosen package version requirements.

@@ -1,14 +1,14 @@ cabal-version:       2.4
 name:                data-validation
-version:             0.1.0.2
+version:             0.1.2.0
 synopsis:            A library for creating type safe validations.
 description:
   A library for creating type safe validations using typeclasses.
 homepage:            https://github.com/alasconnect/data-validation
 license:             Apache-2.0
 license-file:        LICENSE
-author:              Alasconnect
-maintainer:          Alasconnect <software@alasconnect.com>
+author:              Ampersand
+maintainer:          Ampersand <software@ampersandtech.com>
 copyright:           2020 AlasConnect LLC
 category:            Data
 extra-source-files:  CHANGELOG.md, README.md
@@ -16,16 +16,26 @@ source-repository head
   type: git
   location: https://github.com/alasconnect/data-validation
-  tag: 0.1.0.2
+  tag: 0.1.2.0
 
 library
   exposed-modules:    Data.Validation
                     , Data.Validation.Internal
                     , Data.Validation.Transforms
-  build-depends:      base >= 4.11.0.1 && <= 4.12.0.0
-                    , template-haskell >= 2.13.0.0 && < 2.15
-                    , containers >= 0.5.11.0 && < 0.7
+  build-depends:      base >= 4.11.0.1 && < 5
+                    , template-haskell >= 2.13 && < 2.16
+                    , containers >= 0.5.11 && < 0.7
   hs-source-dirs:     src
+  default-language:   Haskell2010
+  ghc-options:       -Wall -v0
+
+library examples
+  exposed-modules:    Examples.Data.ComplexTypes
+                    , Examples.Data.Primitives
+  build-depends:      base >= 4.11.0.1 && < 5
+                    , data-validation
+                    , regex-tdfa
+  hs-source-dirs:     examples
   default-language:   Haskell2010
   ghc-options:       -Wall -v0
 

@@ -0,0 +1,55 @@+{-# LANGUAGE
+    MultiParamTypeClasses
+  , TemplateHaskellQuotes
+#-}
+
+module Examples.Data.ComplexTypes where
+
+------------------------------------------------------------------------------------------------------------------------
+import Data.Validation
+------------------------------------------------------------------------------------------------------------------------
+import Examples.Data.Primitives
+------------------------------------------------------------------------------------------------------------------------
+
+-- View Model
+data UserVM
+  = UserVM
+  { userVMUsername          :: Maybe String
+  , userVMEmailAddress      :: Maybe String
+  , userVMPhoneNumber       :: Maybe String
+  , userVMContactPreference :: Maybe ContactPreference
+  , userVMZipCode           :: Maybe String
+  } deriving (Show)
+
+-- Actual Model
+data User
+  = User
+  { userUsername          :: Username
+  , userEmailAddress      :: Maybe EmailAddress
+  , userPhoneNumber       :: Maybe PhoneNumber
+  , userContactPreference :: ContactPreference
+  , userZipCode           :: Maybe ZipCode
+  } deriving (Show)
+
+instance Validatable MyFailures UserVM User where
+  validation u = do
+    let vn = withField 'userVMUsername (userVMUsername u) $
+          \n -> isRequired RequiredFailure n
+          >>= refuteWithProof mkUsername
+        -- EmailAdress and PhoneNumber are only required when ContactPreference matches
+        ve = withField 'userVMEmailAddress (userVMEmailAddress u) $
+          \me -> isRequiredWhen RequiredFailure (userVMContactPreference u == Just Email) me
+          >>= whenJust (refuteWithProof mkEmailAddress)
+        vp = withField 'userVMPhoneNumber (userVMPhoneNumber u) $
+            \mp -> isRequiredWhen RequiredFailure (userVMContactPreference u == Just Phone) mp
+            >>= whenJust (refuteWithProof mkPhoneNumber)
+        cp = withField 'userVMContactPreference (userVMContactPreference u) $
+          \p -> isRequired RequiredFailure p
+        -- ZipCode is completely optional
+        zc = optional (userVMZipCode u) $ \z ->
+          withField 'userVMZipCode z $ refuteWithProof mkZipCode
+        otherCheck = withValue u check
+    pure User <*> vn <*> ve <*> vp <*> cp <*> zc <! otherCheck
+    where
+      -- arbitrary check
+      check = disputeWithFact OtherFailure (\v -> userVMUsername v /= userVMEmailAddress v)

@@ -0,0 +1,73 @@+{-# LANGUAGE
+    MultiParamTypeClasses
+  , TemplateHaskellQuotes
+#-}
+
+module Examples.Data.Primitives
+( MyFailures (..)
+, Username
+, mkUsername
+, unUsername
+, EmailAddress
+, mkEmailAddress
+, unEmailAddress
+, PhoneNumber
+, mkPhoneNumber
+, unPhoneNumber
+, ContactPreference (..)
+, ZipCode
+, mkZipCode
+, unZipCode
+) where
+
+------------------------------------------------------------------------------------------------------------------------
+import Data.Validation
+import Text.Regex.TDFA ((=~))
+------------------------------------------------------------------------------------------------------------------------
+
+data MyFailures
+  = NameFailure
+  | LengthFailure
+  | EmailFailure
+  | RequiredFailure
+  | OtherFailure
+
+instance Show MyFailures where
+  show NameFailure = "that's a stupid name"
+  show LengthFailure = "length wrong"
+  show EmailFailure = "bad email"
+  show RequiredFailure = "required field missing value"
+  show OtherFailure = "something else wrong"
+
+-- app specific types
+newtype Username = Username { unUsername :: String }
+  deriving Show
+mkUsername :: String -> Proof MyFailures Username
+mkUsername s = fromVCtx $ do
+  v <- withValue s (isNotNull NameFailure)
+  return $ Username v
+
+newtype EmailAddress = EmailAddress { unEmailAddress :: String }
+  deriving Show
+mkEmailAddress :: String -> Proof MyFailures EmailAddress
+mkEmailAddress s = fromVCtx $ do
+  -- validates email matches a Regex using <https://hackage.haskell.org/package/regex-tdfa regex-tdfa>.
+  v <- withValue s (disputeWithFact EmailFailure (flip (=~) "[a-zA-Z0-9+._-]+@[a-zA-Z-]+\\.[a-z]+"))
+  return $ EmailAddress v
+
+newtype PhoneNumber = PhoneNumber { unPhoneNumber :: String }
+  deriving Show
+mkPhoneNumber :: String -> Proof MyFailures PhoneNumber
+mkPhoneNumber s = fromVCtx $ do
+  v <- withValue s (isLength 7 LengthFailure)
+  return $ PhoneNumber v
+
+data ContactPreference
+  = Email | Phone deriving (Enum, Eq, Show)
+
+newtype ZipCode = ZipCode { unZipCode :: String }
+  deriving Show
+mkZipCode :: String -> Proof MyFailures ZipCode
+mkZipCode s = fromVCtx $ do
+  v <- withValue s (isNotNull OtherFailure)
+  return $ ZipCode v

@@ -39,6 +39,8 @@ , disputeWithFact
 -- * General Validators
 , isRequired
+, isRequiredWhen
+, isRequiredUnless
 , isLeft
 , isRight
 , isNull
@@ -62,10 +64,12 @@ -- * Validation Helpers
 , validateField
 , optional
+, whenJust
 , aggregateFailures
 , (<!)
 , isValid
 , isInvalid
+, flattenProofs
 -- * Re-exports
 , VCtx
 , Name
@@ -76,7 +80,7 @@ ------------------------------------------------------------------------------------------------------------------------
 import Prelude hiding (foldl)
 import Data.Bool
-import Data.Either (Either(..), rights, lefts)
+import Data.Either (rights, lefts)
 import Data.Foldable (fold)
 import Data.Map hiding (null, fold)
 import Data.Maybe
@@ -240,8 +244,7 @@ 
 -- | Replaces the existing value with a new one without changing the name, if one exists.
 setValue :: ValueCtx a -> b -> ValueCtx b
-setValue (Field n _) b = Field n b
-setValue (Global _) b  = Global b
+setValue v b = b <$ v
 
 -- | Performs some given validation using a 'Field' with a given name and value.
 withField :: Name -> a -> (ValueCtx a -> VCtx f (ValueCtx b)) -> VCtx f b
@@ -478,6 +481,21 @@   Nothing -> Left f
   Just a  -> Right a
 
+-- | Checks that a 'Data.Maybe.Maybe' value is a 'Data.Maybe.Just' when some condition is true.
+-- If the condition is met and the value is 'Data.Maybe.Just', 
+-- it adds the given failure to the result and validation continues.
+isRequiredWhen :: f -> Bool -> ValueCtx (Maybe a) -> VCtx f (ValueCtx (Maybe a))
+isRequiredWhen _ False v = return v
+isRequiredWhen f True v  = flip disputeWith v $ \ma -> case ma of
+  Nothing -> Just f
+  Just _  -> Nothing
+
+-- | Checks that a 'Data.Maybe.Maybe' value is a 'Data.Maybe.Just' when some condition is false.
+-- If the condition is not met and the value is 'Data.Maybe.Just', 
+-- it adds the given failure to the result and validation continues.
+isRequiredUnless :: f -> Bool -> ValueCtx (Maybe a) -> VCtx f (ValueCtx (Maybe a))
+isRequiredUnless f b v = isRequiredWhen f (not b) v
+
 -- | Checks that a 'Data.Either.Either' value is a 'Data.Either.Left'.
 -- If not, it adds the given failure to the result and validation end.
 isLeft :: f -> ValueCtx (Either a b) -> VCtx f (ValueCtx a)
@@ -493,26 +511,26 @@   Left _  -> Left f
 
 -- | Checks that the 'Foldable' is empty.
--- If so, it adds the given failure to the result and validation continues.
+-- If not, it adds the given failure to the result and validation continues.
 isNull :: Foldable t => f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a))
 isNull f = disputeWith $ bool (Just f) Nothing . null
 
 -- | Checks that the 'Foldable' is not empty.
--- If not, it adds the given failure to the result and validation continues.
+-- If empty, it adds the given failure to the result and validation continues.
 isNotNull :: Foldable t => f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a))
 isNotNull f = disputeWith $ bool (Just f) Nothing . not . null
 
--- | Checks that a 'IsString' has a length equal to or grater than the given value.
+-- | Checks that a 'Foldable' has a length equal to or greater than the given value.
 -- If not, it adds the given failure to the result and validation continues.
 minLength :: Foldable t => Int -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a))
 minLength l f = disputeWith $ bool (Just f) Nothing . (<=) l . length
 
--- | Checks that a 'IsString' has a length equal to or less than the given value.
+-- | Checks that a 'Foldable' has a length equal to or less than the given value.
 -- If not, it adds the given failure to the result and validation continues.
 maxLength :: Foldable t => Int -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a))
 maxLength l f = disputeWith $ bool (Just f) Nothing . (>=) l . length
 
--- | Checks that a 'IsString' has a length equal the given value.
+-- | Checks that a 'Foldable' has a length equal to the given value.
 -- If not, it adds the given failure to the result and validation continues.
 isLength :: Foldable t => Int -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a))
 isLength l f = disputeWith $ bool (Just f) Nothing . (==) l . length
@@ -523,16 +541,16 @@ isEqual a f = disputeWith $ bool (Just f) Nothing . (==) a
 
 -- | Checks that a value is not equal to another.
--- If not, it adds the given failure to the result and validation continues.
+-- If equal, it adds the given failure to the result and validation continues.
 isNotEqual :: Eq a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a)
 isNotEqual a f = disputeWith $ bool (Just f) Nothing . (/=) a
 
--- | Checks that a value is less than to another.
+-- | Checks that a value is less than another.
 -- If not, it adds the given failure to the result and validation continues.
 isLessThan :: Ord a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a)
 isLessThan a f = disputeWith $ bool (Just f) Nothing . (>) a
 
--- | Checks that a value is greater than to another.
+-- | Checks that a value is greater than another.
 -- If not, it adds the given failure to the result and validation continues.
 isGreaterThan :: Ord a => a -> f -> ValueCtx a -> VCtx f (ValueCtx a)
 isGreaterThan a f = disputeWith $ bool (Just f) Nothing . (<) a
@@ -553,7 +571,7 @@ hasElem e f = disputeWith $ bool (Just f) Nothing . elem e
 
 -- | Checks that a 'Foldable' does not have a given element.
--- If not, it adds the given failure to the result and validation continues.
+-- If it has element, it adds the given failure to the result and validation continues.
 doesNotHaveElem :: (Foldable t, Eq a) => a -> f -> ValueCtx (t a) -> VCtx f (ValueCtx (t a))
 doesNotHaveElem e f = disputeWith $ bool (Just f) Nothing . not . elem e
 
@@ -583,9 +601,9 @@ 
 -- | Validate each element with a given function.
 ifEachProven :: (a -> Proof f b) -> ValueCtx [a] -> VCtx f (ValueCtx [b])
-ifEachProven fn v = 
+ifEachProven fn v =
   let p = fold $ fmap (fmap (\b -> [b]) . fn) $ getValue v
-  in case p of 
+  in case p of
     Valid es -> pure $ setValue v es
     Invalid gfs lfs -> case v of
       Global _  -> RefutedCtx gfs lfs
@@ -657,6 +675,13 @@     DisputedCtx gfs lfs b -> DisputedCtx gfs lfs (Just b)
     RefutedCtx gfs lfs    -> RefutedCtx gfs lfs
 
+-- | Allows for validation of an optional value.
+-- See `Validating Complex Types` for an example.
+whenJust :: (ValueCtx a -> VCtx f (ValueCtx b)) -> ValueCtx (Maybe a) -> VCtx f (ValueCtx (Maybe b))
+whenJust fn v = case getValue v of
+  Nothing -> pure $ Nothing <$ v
+  Just a  -> fmap (fmap Just) $ fn $ a <$ v
+
 -- | tests if a 'Proof' is valid.
 isValid :: Proof f a -> Bool
 isValid (Valid _)     = True
@@ -665,3 +690,7 @@ -- | tests if a 'Proof' is invalid.
 isInvalid :: Proof f a -> Bool
 isInvalid = not . isValid
+
+-- | Flatten a list of proofs into a proof of the list
+flattenProofs :: [Proof f a] -> Proof f [a]
+flattenProofs al = mconcat $ fmap (:[]) <$> al

@@ -134,6 +134,31 @@         r = isRequired "Failed" v
       r `shouldBe` pure v2
 
+  describe "isRequiredWhen" $ do
+    it "Adds a failure to the context if the condition is True and the value is Nothing." $ do
+      let
+        v = Global (Nothing :: Maybe Bool)
+        r = isRequiredWhen "Failed" True v
+      r `shouldBe` dispute v "Failed"
+
+    it "Should add no failure when the condition is False and the value is Nothing." $ do
+      let
+        v = Global (Nothing :: Maybe Bool)
+        r = isRequiredWhen "Failed" False v
+      r `shouldBe` pure v
+
+    it "Should add no failure if the condition is True and the value is Just." $ do
+      let
+        v = Global $ Just True
+        r = isRequiredWhen "Failed" True v
+      r `shouldBe` pure v
+
+    it "Should add no failure if the condition is False and the value is Just." $ do
+      let
+        v = Global $ Just True
+        r = isRequiredWhen "Failed" False v
+      r `shouldBe` pure v
+
   describe "isLeft" $ do
     it "Adds a failure to the context if the value is Right." $ do
       let
@@ -469,6 +494,24 @@       fromVCtx (validateField c) `shouldBe` Invalid [] (fromList [
           ([(mkName "contact"), 'phoneNumber], ["Phone Number cannot be empty."])
         ])
+
+  describe "optional" $ do
+    it "Nothing value is valid if optional" $ do
+      let proof = fromVCtx $ optional (Nothing :: Maybe ContactVM) $ \v -> withValue v $ validateField
+      proof `shouldBe` Valid Nothing
+    it "Just value is will validate if optional" $ do
+      let c = (ContactVM "")
+      let proof = fromVCtx $ optional (Just c) $ \v -> withValue v $ validateField
+      proof `shouldBe` Invalid [] (fromList [(['phoneNumber], ["Phone Number cannot be empty."])])
+
+  describe "whenJust" $ do
+    it "Nothing value is valid if optional" $ do
+      let proof = fromVCtx $ withValue (Nothing :: Maybe ContactVM) $ whenJust validateField
+      proof `shouldBe` Valid Nothing
+    it "Just value is will validate if optional" $ do
+      let c = (ContactVM "")
+      let proof = fromVCtx $ withValue (Just c) $ whenJust validateField
+      proof `shouldBe` Invalid [] (fromList [(['phoneNumber], ["Phone Number cannot be empty."])])
 
 data Contact
   = Contact