diff --git a/Application/Helper/Controller.hs b/Application/Helper/Controller.hs
index 15c8399..12162bf 100644
--- a/Application/Helper/Controller.hs
+++ b/Application/Helper/Controller.hs
@@ -41,4 +41,16 @@ rsaPrivateKey = (getAppConfig @Config.RsaKeys).privateKey
rsaSignatureMatches :: (?context :: ControllerContext) => Text -> Text -> Bool
rsaSignatureMatches original signature = case Base64.decode $ cs signature of
Left msg -> False
- Right decodedSignature -> RSA.PKCS15.verify (Just Hash.Algorithms.SHA256) rsaPublicKey (cs original) decodedSignature
\ No newline at end of file
+ Right decodedSignature -> RSA.PKCS15.verify (Just Hash.Algorithms.SHA256) rsaPublicKey (cs original) decodedSignature
+
+setFormStatus :: (?context :: ControllerContext) => FormStatus -> IO ()
+setFormStatus formStatus = setSession "formStatus" (show formStatus)
+
+-- | Get the form status from the session and clear it.
+getAndClearFormStatus :: (?context :: ControllerContext) => IO FormStatus
+getAndClearFormStatus = do
+ maybeFormStatus <- getSessionAndClear @Text "formStatus"
+ pure $ case maybeFormStatus of
+ Just "FormStatusSuccess" -> FormStatusSuccess
+ Just "FormStatusError" -> FormStatusError
+ _ -> FormStatusNotSubmitted
\ No newline at end of file
diff --git a/Application/Helper/View.hs b/Application/Helper/View.hs
index 7bb88f9..da521c6 100644
--- a/Application/Helper/View.hs
+++ b/Application/Helper/View.hs
@@ -6,6 +6,7 @@ import "cryptonite" Crypto.Hash.Algorithms as Hash.Algorithms
import Data.ByteString.Base64 as Base64
import Application.Helper.Controller
import qualified Text.MMark as MMark
+import Web.Types
-- Here you can add functions which are available in all your views
@@ -22,4 +23,5 @@ renderMarkdown text =
case text |> MMark.parse "" of
-- On error, render the text as is.
Left error -> cs text
- Right markdown -> MMark.render markdown |> tshow |> preEscapedToHtml
\ No newline at end of file
+ Right markdown -> MMark.render markdown |> tshow |> preEscapedToHtml
+
diff --git a/Web/Controller/ImageStyle.hs b/Web/Controller/ImageStyle.hs
index 72d4f7b..b5fe4a6 100644
--- a/Web/Controller/ImageStyle.hs
+++ b/Web/Controller/ImageStyle.hs
@@ -10,7 +10,7 @@ import "cryptonite" Crypto.PubKey.RSA.PKCS15 as RSA
import "cryptonite" Crypto.Hash.Algorithms as Hash.Algorithms
import Config
import Data.ByteString.Base64 as Base64
-import qualified Data.UUID as UUID (fromString)
+import qualified Data.UUID as UUID (fromText)
instance Controller ImageStyleController where
action RenderImageStyleAction { width, height, originalImagePath, signed } = do
@@ -38,7 +38,7 @@ instance Controller ImageStyleController where
let options :: StoreFileOptions = def
{ directory = imageStylePathDirectory
, preprocess = applyImageMagick "jpg" ["-resize", cs size <> "^", "-gravity", "center", "-extent", cs size, "-quality", "85%", "-strip"]
- , fileName = UUID.fromString (cs uuid)
+ , fileName = UUID.fromText uuid
}
storedFile <- storeFileFromPath (cs $ storagePrefix <> originalImageDirectory <> "/" <> uuid) options
diff --git a/Web/Controller/LandingPages.hs b/Web/Controller/LandingPages.hs
index e912a5c..5ae740f 100644
--- a/Web/Controller/LandingPages.hs
+++ b/Web/Controller/LandingPages.hs
@@ -13,6 +13,7 @@ instance Controller LandingPagesController where
action NewLandingPageAction = do
let landingPage = newRecord
+ setFormStatus FormStatusNotSubmitted
render NewView { .. }
action ShowLandingPageAction { landingPageId } = do
@@ -23,6 +24,8 @@ instance Controller LandingPagesController where
action EditLandingPageAction { landingPageId } = do
landingPageWithRecords <- fetchLandingPageWithRecords landingPageId
+ formStatus <- getAndClearFormStatus
+
render EditView { .. }
action UpdateLandingPageAction { landingPageId } = do
@@ -41,7 +44,9 @@ instance Controller LandingPagesController where
|> set #meta landingPage'.meta
|> set #title landingPage'.title
- render EditView { landingPageWithRecords = landingPageWithRecords {landingPage = landingPageWithMeta}}
+ let formStatus = FormStatusError
+
+ render EditView { landingPageWithRecords = landingPageWithRecords {landingPage = landingPageWithMeta}, formStatus = formStatus }
Right landingPage -> do
landingPage <- landingPage |> updateRecord
@@ -83,6 +88,7 @@ instance Controller LandingPagesController where
pure ()
setSuccessMessage "LandingPage updated"
+ setFormStatus FormStatusSuccess
redirectTo EditLandingPageAction { .. }
action CreateLandingPageAction = do
@@ -90,10 +96,13 @@ instance Controller LandingPagesController where
landingPage
|> buildLandingPage
|> ifValid \case
- Left landingPage -> render NewView { .. }
+ Left landingPage -> do
+ setFormStatus FormStatusError
+ render NewView { .. }
Right landingPage -> do
landingPage <- landingPage |> createRecord
setSuccessMessage "LandingPage created"
+ setFormStatus FormStatusSuccess
-- After we create the Landing page, we can start adding Paragraphs to it.
redirectTo EditLandingPageAction { landingPageId = landingPage.id }
diff --git a/Web/Controller/ParagraphQuotes.hs b/Web/Controller/ParagraphQuotes.hs
index 793beac..0728df5 100644
--- a/Web/Controller/ParagraphQuotes.hs
+++ b/Web/Controller/ParagraphQuotes.hs
@@ -11,26 +11,34 @@ instance Controller ParagraphQuotesController where
|> set #landingPageId landingPageId
|> set #weight weight
+ let formStatus = FormStatusNotSubmitted
+
render NewView { .. }
action EditParagraphQuoteAction { paragraphQuoteId } = do
paragraphQuote <- fetch paragraphQuoteId
+ -- Get from the session, if the form was submitted successfully.
+ formStatus <- getAndClearFormStatus
render EditView { .. }
action UpdateParagraphQuoteAction { paragraphQuoteId } = do
let uploadImage = uploadToStorageWithOptions $ def
{ preprocess = applyImageMagick "jpg" ["-resize", "1024x1024^", "-gravity", "north", "-extent", "1024x1024", "-quality", "85%", "-strip"] }
+ formStatus <- getAndClearFormStatus
paragraphQuote <- fetch paragraphQuoteId
paragraphQuote
|> uploadImage #imageUrl
>>= buildParagraphQuote
>>= ifValid \case
- Left paragraphQuote -> render EditView { .. }
+ Left paragraphQuote -> do
+ setFormStatus FormStatusError
+ render EditView { .. }
Right paragraphQuote -> do
paragraphQuote <- paragraphQuote |> updateRecord
setSuccessMessage "Quote updated"
+ -- We don't setFormStatus, since we redirect to a new page.
redirectTo EditLandingPageAction { landingPageId = paragraphQuote.landingPageId }
action CreateParagraphQuoteAction = do
@@ -38,15 +46,19 @@ instance Controller ParagraphQuotesController where
{ preprocess = applyImageMagick "jpg" ["-resize", "1024x1024^", "-gravity", "north", "-extent", "1024x1024", "-quality", "85%", "-strip"] }
let paragraphQuote = newRecord @ParagraphQuote
+ let formStatus = FormStatusNotSubmitted
paragraphQuote
|> uploadImage #imageUrl
>>= buildParagraphQuote
>>= ifValid \case
- Left paragraphQuote -> render NewView { .. }
+ Left paragraphQuote -> do
+ setFormStatus FormStatusError
+ render NewView { .. }
Right paragraphQuote -> do
paragraphQuote <- paragraphQuote |> createRecord
setSuccessMessage "Quote created"
+ -- We don't setFormStatus, since we redirect to a new page.
redirectTo EditLandingPageAction { landingPageId = paragraphQuote.landingPageId }
action DeleteParagraphQuoteAction { paragraphQuoteId } = do
diff --git a/Web/Element/InnerElementLayout.hs b/Web/Element/InnerElementLayout.hs
deleted file mode 100644
index f226d2d..0000000
--- a/Web/Element/InnerElementLayout.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Web.Element.InnerElementLayout where
-
-import Web.View.Prelude
-
-import Web.Element.Types
-
-
-getInnerElementBaseClasses :: Text
-getInnerElementBaseClasses = "relative rounded-lg border border-gray-300 w-full h-full overflow-hidden"
-
-buildInnerElementLayout :: Color -> Html -> Html
-buildInnerElementLayout color element =
- [hsx|
-
- {element}
-
- |]
- where
- classes' = classes
- [ (getInnerElementBaseClasses, True)
- , (getBackgroundColor color, True)
- , "p-6 md:px-8"
- ]
-
-
--- @todo: Remove
-buildElementLayoutSplitImageAndContent :: Text -> Html -> Html
-buildElementLayoutSplitImageAndContent imageUrl items =
- -- We use grid and row/col start to position both the image and the text on the same cell.
- [hsx|
-
-
-
-
-
-
- {items}
-
-
- |]
- where
- image = [hsx||]
diff --git a/Web/Element/SubmitButton.hs b/Web/Element/SubmitButton.hs
new file mode 100644
index 0000000..584fd9e
--- /dev/null
+++ b/Web/Element/SubmitButton.hs
@@ -0,0 +1,39 @@
+module Web.Element.SubmitButton where
+
+import Web.View.Prelude
+
+import Application.Helper.Icons
+import Web.Element.ElementWrap
+import Web.Element.Types
+
+renderSubmitButtonwithFormStatus :: SubmitButton -> FormStatus -> Html
+renderSubmitButtonwithFormStatus submitButton formStatus = [hsx|
+ {submitButton}
+
+ {- We show only one of these messages -}
+
+ {formStatusMessage}
+
+|]
+ |> wrapHorizontalSpacing AlignEnd
+ where
+ formStatusWrapper element = [hsx|
{element}
|]
+ maybeFormStatusMessage =
+ case formStatus of
+ FormStatusNotSubmitted -> Nothing
+
+ FormStatusSuccess ->
+ "Changes saved"
+ |> wrapTextColor Green600
+ |> Just
+
+ FormStatusError ->
+ "Errors in the form"
+ |> wrapTextColor Red600
+ |> Just
+
+ formStatusMessage = maybeFormStatusMessage
+ |> fromMaybe ""
+ |> wrapTextItalic
+ |> \e -> [hsx|
{e}
|]
+
diff --git a/Web/Types.hs b/Web/Types.hs
index 29fc2bc..5878b64 100644
--- a/Web/Types.hs
+++ b/Web/Types.hs
@@ -19,6 +19,16 @@ data LandingPageWithRecords = LandingPageWithRecords
, paragraphQuotes :: ![ParagraphQuote]
} deriving (Show)
+{-| With the `FormStatus` we can show a message to the user after submitting a form,
+indicating if the form was successful or not.
+-}
+data FormStatus
+ = FormStatusNotSubmitted
+ | FormStatusSuccess
+ | FormStatusError deriving (Eq, Show)
+
+-- Instances
+
instance CanSelect LandingPage where
type SelectValue LandingPage = Id LandingPage
selectValue landingPage = landingPage.id
diff --git a/Web/View/CustomCSSFramework.hs b/Web/View/CustomCSSFramework.hs
index 3f284de..594df65 100644
--- a/Web/View/CustomCSSFramework.hs
+++ b/Web/View/CustomCSSFramework.hs
@@ -203,7 +203,8 @@ customTailwind = def
|]
- styledSubmitButtonClass = "bg-blue-500 hover:bg-blue-700 text-white font-bold py-2 px-4 rounded"
+ -- We set the style of the submit button on app.css.
+ styledSubmitButtonClass = "btn"
styledFormFieldHelp _ FormField { helpText = "" } = mempty
styledFormFieldHelp _ FormField { helpText } = [hsx|