diff --git a/IHP/HaskellSupport.hs b/IHP/HaskellSupport.hs index 282bf3a2c..8ed2a3e52 100644 --- a/IHP/HaskellSupport.hs +++ b/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 diff --git a/IHP/ModelSupport.hs b/IHP/ModelSupport.hs index 4350ff71e..bc2dc947a 100644 --- a/IHP/ModelSupport.hs +++ b/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, diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs index 0776f7ac4..aa4d48917 100644 --- a/IHP/RouterSupport.hs +++ b/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 diff --git a/IHP/ValidationSupport/ValidateField.hs b/IHP/ValidationSupport/ValidateField.hs index a77020f13..c84820164 100644 --- a/IHP/ValidationSupport/ValidateField.hs +++ b/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))