Merge pull request #259 from digitallyinduced/did-change

Added includes, didChange, didChangeRecord

IHP/HaskellSupport.hs

@@ -25,6 +25,7 @@ module IHP.HaskellSupport (
 , isWeekend
 , todayIsWeekend
 , debug
+, includes
 ) where
 
 import ClassyPrelude
@@ -60,6 +61,19 @@ whenNonEmpty :: (MonoFoldable a, Applicative f) => a -> f () -> f ()
 whenNonEmpty condition = unless (isEmpty condition)
 {-# INLINE whenNonEmpty #-}
 
+-- Returns 'True' when a value is contained in the given list, array, set, ...
+--
+-- Alias for 'elem', but with a nicer name :)
+--
+-- >>> ["hello", "world"] |> includes "hello"
+-- True
+--
+-- >>> "Hello" |> includes 'H'
+-- True
+includes :: (MonoFoldable container, Eq (Element container)) => Element container -> container -> Bool
+includes = elem
+{-# INLINE includes #-}
+
 instance Data.Default.Default Data.UUID.UUID where
     def = Data.UUID.nil
 

IHP/ModelSupport.hs

@@ -281,6 +281,54 @@ instance SetField "annotations" MetaBag [(Text, Text)] where
 instance SetField "touchedFields" MetaBag [Text] where
     setField value meta = meta { touchedFields = value }
 
+-- | Returns 'True' if any fields of the record have unsaved changes
+--
+-- __Example:__ Returns 'False' for freshly fetched records
+--
+-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
+-- >>> project <- fetch projectId
+-- >>> didChangeRecord project
+-- False
+--
+-- __Example:__ Returns 'True' after setting a field
+--
+-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
+-- >>> project <- fetch projectId
+-- >>> project |> set #name "New Name" |> didChangeRecord
+-- True
+didChangeRecord :: (HasField "meta" record MetaBag) => record -> Bool
+didChangeRecord record =
+    record
+    |> get #meta
+    |> get #touchedFields
+    |> isEmpty
+
+-- | Returns 'True' if the specific field of the record has unsaved changes
+--
+-- __Example:__ Returns 'False' for freshly fetched records
+--
+-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
+-- >>> project <- fetch projectId
+-- >>> didChange #name project
+-- False
+--
+-- __Example:__ Returns 'True' after setting a field
+--
+-- >>> let projectId = "227fbba3-0578-4eb8-807d-b9b692c3644f" :: Id Project
+-- >>> project <- fetch projectId
+-- >>> project |> set #name "New Name" |> didChange #name
+-- True
+--
+-- __Example:__ Setting a flash message after updating the profile picture
+--
+-- > when (user |> didChange #profilePictureUrl) (setSuccessMessage "Your Profile Picture has been updated. It might take a few minutes until it shows up everywhere")
+didChange :: (KnownSymbol fieldName, HasField fieldName record fieldValue, HasField "meta" record MetaBag) => Proxy fieldName -> record -> Bool
+didChange field record =
+    record
+    |> get #meta
+    |> get #touchedFields
+    |> includes (cs $! symbolVal field)
+
 -- | Represents fields that have a default value in an SQL schema
 --
 --   The 'Default' constructor represents the default value from the schema,

IHP/RouterSupport.hs

@@ -137,9 +137,8 @@ class Data controller => AutoRoute controller where
 
                     checkRequestMethod action = do
                             method <- getMethod
-                            if method `elem` allowedMethods
-                                then pure action
-                                else error ("Invalid method, expected one of: " <> show allowedMethods)
+                            unless (allowedMethods |> includes method) (error ("Invalid method, expected one of: " <> show allowedMethods))
+                            pure action
         in choice (map parseCustomAction allConstructors)
 
     parseArgument :: forall d. Data d => ByteString -> ByteString -> d

IHP/ValidationSupport/ValidateField.hs

@@ -401,5 +401,5 @@ isUrl text = Failure "is not a valid url. It needs to start with http:// or http
 
 
 isInList :: (Eq value, Show value) => [value] -> value -> ValidatorResult
-isInList list value | value `elem` list = Success
+isInList list value | list |> includes value = Success
 isInList list value = Failure ("is not allowed. It needs to be one of the following: " <> (tshow list))