FormStatus with JS helpers (#45)

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
+    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

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
+        Right markdown -> MMark.render markdown |> tshow |> preEscapedToHtml
+

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

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,17 +88,21 @@ instance Controller LandingPagesController where
                                     pure ()
 
                     setSuccessMessage "LandingPage updated"
+                    setFormStatus FormStatusSuccess
                     redirectTo EditLandingPageAction { .. }
 
     action CreateLandingPageAction = do
         let landingPage = newRecord @LandingPage
         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 }
 

Web/Controller/ParagraphQuotes.hs

@@ -11,42 +11,54 @@ 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
         let uploadImage = uploadToStorageWithOptions $ def
                 { 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

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 -}
+    <div class="form-status">
+        {formStatusMessage}
+    </div>
+|]
+    |> wrapHorizontalSpacing AlignEnd
+    where
+        formStatusWrapper element = [hsx|<div class="form-status">{element}</div>|]
+        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|<div class="form-status-wrapper">{e}</div>|]
+

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

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|<p class="text-gray-600 text-xs italic">{helpText}</p>|]

Web/View/LandingPages/Edit.hs

@@ -3,31 +3,32 @@ import Web.Controller.Prelude
 import Web.Element.Button
 import Web.Element.ElementWrap
 import Web.Element.Link
+import Web.Element.SubmitButton
 import Web.Element.Types
 import Web.View.Prelude
 
-data EditView = EditView { landingPageWithRecords :: LandingPageWithRecords }
+data EditView = EditView
+    { landingPageWithRecords :: LandingPageWithRecords
+    , formStatus :: FormStatus
+    }
+
 
 instance View EditView where
-    html EditView { .. } = [hsx|
-        {body}
-    |]
+    html EditView { .. } =
+        [ header
+        , renderForm landingPage paragraphCtas paragraphQuotes formStatus
+        ]
+        |> mconcat
+        |> wrapVerticalSpacing AlignNone
+        |> wrapContainerWide
         where
-            body =
-                [ header
-                , renderForm landingPage paragraphCtas paragraphQuotes
-                ]
-                |> mconcat
-                |> wrapVerticalSpacing AlignNone
-                |> wrapContainerWide
-
             landingPage = landingPageWithRecords.landingPage
             paragraphCtas = landingPageWithRecords.paragraphCtas
             paragraphQuotes = landingPageWithRecords.paragraphQuotes
 
             breadcrumb = renderBreadcrumb
-                [ breadcrumbLink "LandingPages" LandingPagesAction
-                , breadcrumbText "Edit LandingPage"
+                [ breadcrumbLink "Landing Pages" LandingPagesAction
+                , breadcrumbText "Edit Landing Page"
                 ]
 
             header =
@@ -45,11 +46,8 @@ instance View EditView where
                 |> mconcat
                 |> wrapHorizontalSpacingTiny AlignBaseline
 
-renderForm :: LandingPage -> [ParagraphCta] -> [ParagraphQuote] -> Html
-renderForm landingPage paragraphCtas paragraphQuotes = formFor landingPage [hsx|
-    {body}
-|]
-
+renderForm :: LandingPage -> [ParagraphCta] -> [ParagraphQuote] -> FormStatus -> Html
+renderForm landingPage paragraphCtas paragraphQuotes formStatus = formFor landingPage body
     where
         body :: (?formContext :: FormContext LandingPage) => Html
         body = [hsx|
@@ -59,13 +57,16 @@ renderForm landingPage paragraphCtas paragraphQuotes = formFor landingPage [hsx|
                 {paragraphs}
             </div>
 
-            {submitButton {label = "Save Landing page"}}
+            { renderSubmitButtonwithFormStatus
+                (submitButton {label = "Save Landing page"})
+                formStatus
+            }
         |]
             |> wrapVerticalSpacing AlignNone
 
         paragraphs =
-            [   addParagraphs
-            ,   [hsx|
+            [ addParagraphs
+            , [hsx|
                     <ul class="js-sortable">
                         {orderAndRenderParagraphs paragraphCtas paragraphQuotes}
                     </ul>

Web/View/Layout.hs

@@ -28,7 +28,7 @@ defaultLayout currentTime inner = [hsx|
         <div class="flex flex-col min-h-screen">
             <div class="flex-1">
                 <div class="font-body text-black flex flex-col gap-y-8 md:gap-y-10">
-                    {renderFlashMessages}
+                    {renderFlashMessages |> wrapContainerWide}
                     {inner}
                 </div>
             </div>

Web/View/ParagraphQuotes/Edit.hs

@@ -2,13 +2,16 @@ module Web.View.ParagraphQuotes.Edit where
 import Web.View.Prelude
 import Web.View.ParagraphQuotes.Form
 
-data EditView = EditView { paragraphQuote :: ParagraphQuote }
+data EditView = EditView
+    { paragraphQuote :: ParagraphQuote
+    , formStatus :: FormStatus
+    }
 
 instance View EditView where
     html EditView { .. } = [hsx|
         {breadcrumb}
         <h1>Edit ParagraphQuote</h1>
-        {renderForm paragraphQuote False}
+        {renderForm paragraphQuote False formStatus}
     |]
         where
             breadcrumb = renderBreadcrumb