diff --git a/Application/Helper/Controller.hs b/Application/Helper/Controller.hs
index 12162bf..c8670c2 100644
--- a/Application/Helper/Controller.hs
+++ b/Application/Helper/Controller.hs
@@ -16,10 +16,13 @@ fetchLandingPageWithRecords :: (?modelContext :: ModelContext) => Id LandingPage
fetchLandingPageWithRecords landingPageId = do
landingPage <- fetch landingPageId
+
paragraphCtas <- fetch landingPage.paragraphCtasRefLandingPages
paragraphQuotes <- fetch landingPage.paragraphQuotes
+ paragraphHeroImages <- fetch landingPage.paragraphHeroImages
+
return $ LandingPageWithRecords { .. }
getParagraphsCount :: (?modelContext::ModelContext) => Id LandingPage -> IO Int
@@ -28,6 +31,7 @@ getParagraphsCount landingPageId = do
pure $ length landingPageWithRecords.paragraphCtas
+ length landingPageWithRecords.paragraphQuotes
+ + length landingPageWithRecords.paragraphHeroImages
+ 1
-- | The RSA public key, can be used to verify image style URLs that were signed.
diff --git a/Application/Schema.sql b/Application/Schema.sql
index fa96c87..85f693f 100644
--- a/Application/Schema.sql
+++ b/Application/Schema.sql
@@ -5,7 +5,6 @@ BEGIN
END;
$$ language plpgsql;
-- Your database schema. Use the Schema Designer at http://localhost:8001/ to add some tables.
-
CREATE TABLE users (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
email TEXT NOT NULL,
@@ -13,7 +12,6 @@ CREATE TABLE users (
locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,
failed_login_attempts INT DEFAULT 0 NOT NULL
);
-
CREATE TABLE landing_pages (
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,
@@ -40,6 +38,16 @@ CREATE TABLE paragraph_ctas (
);
CREATE INDEX paragraph_quotes_landing_page_id_index ON paragraph_quotes (landing_page_id);
CREATE INDEX paragraph_ctas_landing_page_id_index ON paragraph_ctas (landing_page_id);
+CREATE TABLE paragraph_hero_images (
+ id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
+ title TEXT NOT NULL,
+ subtitle TEXT,
+ landing_page_id UUID DEFAULT uuid_generate_v4() NOT NULL,
+ link TEXT DEFAULT NULL,
+ image_url TEXT,
+ weight INT NOT NULL
+);
ALTER TABLE paragraph_ctas ADD CONSTRAINT paragraph_ctas_ref_landing_page_id FOREIGN KEY (landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;
ALTER TABLE paragraph_ctas ADD CONSTRAINT paragraph_ctas_ref_ref_landing_page_id FOREIGN KEY (ref_landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;
+ALTER TABLE paragraph_hero_images ADD CONSTRAINT paragraph_hero_images_ref_landing_page_id FOREIGN KEY (landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;
ALTER TABLE paragraph_quotes ADD CONSTRAINT paragraph_quotes_ref_landing_page_id FOREIGN KEY (landing_page_id) REFERENCES landing_pages (id) ON DELETE NO ACTION;
diff --git a/Web/Controller/LandingPages.hs b/Web/Controller/LandingPages.hs
index 5ae740f..6fccafe 100644
--- a/Web/Controller/LandingPages.hs
+++ b/Web/Controller/LandingPages.hs
@@ -67,6 +67,7 @@ instance Controller LandingPagesController where
-- Iterate over all paragraphs, and update the weight.
forEach landingPageWithRecords.paragraphCtas updateParagraph
forEach landingPageWithRecords.paragraphQuotes updateParagraph
+ forEach landingPageWithRecords.paragraphHeroImages updateParagraph
where
updateParagraph :: forall record.
diff --git a/Web/Controller/ParagraphHeroImages.hs b/Web/Controller/ParagraphHeroImages.hs
new file mode 100644
index 0000000..a500038
--- /dev/null
+++ b/Web/Controller/ParagraphHeroImages.hs
@@ -0,0 +1,75 @@
+module Web.Controller.ParagraphHeroImages where
+
+import Web.Controller.Prelude
+import Web.View.ParagraphHeroImages.New
+import Web.View.ParagraphHeroImages.Edit
+
+instance Controller ParagraphHeroImagesController where
+ action NewParagraphHeroImageAction { .. } = do
+ weight <- getParagraphsCount landingPageId
+ let paragraphHeroImage = newRecord
+ |> set #landingPageId landingPageId
+ |> set #weight weight
+
+ let formStatus = FormStatusNotSubmitted
+
+ render NewView { .. }
+
+ action EditParagraphHeroImageAction { paragraphHeroImageId } = do
+ paragraphHeroImage <- fetch paragraphHeroImageId
+ -- Get from the session, if the form was submitted successfully.
+ formStatus <- getAndClearFormStatus
+ render EditView { .. }
+
+ action UpdateParagraphHeroImageAction { paragraphHeroImageId } = do
+ let uploadImage = uploadToStorageWithOptions $ def
+ { preprocess = applyImageMagick "jpg" ["-resize", "1024x1024^", "-gravity", "north", "-extent", "1024x1024", "-quality", "85%", "-strip"] }
+
+ formStatus <- getAndClearFormStatus
+
+ paragraphHeroImage <- fetch paragraphHeroImageId
+ paragraphHeroImage
+ |> uploadImage #imageUrl
+ >>= buildParagraphHeroImage
+ >>= ifValid \case
+ Left paragraphHeroImage -> do
+ setFormStatus FormStatusError
+ render EditView { .. }
+ Right paragraphHeroImage -> do
+ paragraphHeroImage <- paragraphHeroImage |> updateRecord
+ setSuccessMessage "Hero Image updated"
+ -- We don't setFormStatus, since we redirect to a new page.
+ redirectTo EditLandingPageAction { landingPageId = paragraphHeroImage.landingPageId }
+
+ action CreateParagraphHeroImageAction = do
+ let uploadImage = uploadToStorageWithOptions $ def
+ { preprocess = applyImageMagick "jpg" ["-resize", "1024x1024^", "-gravity", "north", "-extent", "1024x1024", "-quality", "85%", "-strip"] }
+
+ let paragraphHeroImage = newRecord @ParagraphHeroImage
+ let formStatus = FormStatusNotSubmitted
+
+ paragraphHeroImage
+ |> uploadImage #imageUrl
+ >>= buildParagraphHeroImage
+ >>= ifValid \case
+ Left paragraphHeroImage -> do
+ setFormStatus FormStatusError
+ render NewView { .. }
+ Right paragraphHeroImage -> do
+ paragraphHeroImage <- paragraphHeroImage |> createRecord
+ setSuccessMessage "Hero Image created"
+ -- We don't setFormStatus, since we redirect to a new page.
+ redirectTo EditLandingPageAction { landingPageId = paragraphHeroImage.landingPageId }
+
+ action DeleteParagraphHeroImageAction { paragraphHeroImageId } = do
+ paragraphHeroImage <- fetch paragraphHeroImageId
+ deleteRecord paragraphHeroImage
+ setSuccessMessage "Hero Image deleted"
+ redirectTo EditLandingPageAction { landingPageId = paragraphHeroImage.landingPageId }
+
+buildParagraphHeroImage paragraphHeroImage = paragraphHeroImage
+ |> fill @["landingPageId", "weight", "title", "subtitle"]
+ |> validateField #title nonEmpty
+ |> validateField #imageUrl nonEmpty
+ |> return
+
diff --git a/Web/Element/HeroImage.hs b/Web/Element/HeroImage.hs
new file mode 100644
index 0000000..967db78
--- /dev/null
+++ b/Web/Element/HeroImage.hs
@@ -0,0 +1,46 @@
+module Web.Element.HeroImage where
+
+import Web.View.Prelude
+
+import Application.Helper.Icons
+import Web.Element.ElementWrap
+import Web.Element.Types
+
+
+render :: RenderHeroImage -> Html
+render record@RenderHeroImage {title, subtitle, imageUrl} =
+ titleWrapped
+ ++ subTitleWrapped
+ |> wrapVerticalSpacing AlignNone
+ |> renderImageAndContent (pathTo $ RenderImageStyleAction 400 200 imageUrl signed)
+ where
+ -- Sign the image URL to prevent tampering.
+ signed = signImageUrl imageUrl 400 200
+
+ titleWrapped = cs subtitle
+ |> wrapTextResponsiveFontSize TextSizeSm
+
+ subTitleWrapped = cs subtitle
+ |> wrapTextResponsiveFontSize TextSizeSm
+
+
+renderImageAndContent :: Text -> Html -> Html
+renderImageAndContent 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/Types.hs b/Web/Element/Types.hs
index 77eb9e0..6ebe10e 100644
--- a/Web/Element/Types.hs
+++ b/Web/Element/Types.hs
@@ -60,6 +60,12 @@ data RenderQuote = RenderQuote
, imageUrl :: Text
}
+data RenderHeroImage = RenderHeroImage
+ { title :: Text
+ , subtitle :: Text
+ , imageUrl :: Text
+ }
+
-- @todo: Move to Utility.hs?
getBackgroundColor :: Color -> Text
diff --git a/Web/FrontController.hs b/Web/FrontController.hs
index 41ec05f..360efe7 100644
--- a/Web/FrontController.hs
+++ b/Web/FrontController.hs
@@ -12,6 +12,7 @@ import Web.Controller.ImageStyle
import Web.Controller.LandingPages
import Web.Controller.ParagraphCtas
import Web.Controller.ParagraphQuotes
+import Web.Controller.ParagraphHeroImages
import IHP.LoginSupport.Middleware
import Web.Controller.Sessions
@@ -26,6 +27,7 @@ instance FrontController WebApplication where
, parseRoute @LandingPagesController
, parseRoute @ParagraphCtasController
, parseRoute @ParagraphQuotesController
+ , parseRoute @ParagraphHeroImagesController
, parseRoute @SessionsController
]
diff --git a/Web/Routes.hs b/Web/Routes.hs
index 0bd133d..3b4fa13 100644
--- a/Web/Routes.hs
+++ b/Web/Routes.hs
@@ -7,13 +7,12 @@ import Web.Types
instance AutoRoute ParagraphQuotesController
-
instance AutoRoute ParagraphCtasController
+instance AutoRoute ParagraphHeroImagesController
instance AutoRoute LandingPagesController
-
instance AutoRoute ImageStyleController
instance AutoRoute SessionsController
diff --git a/Web/Types.hs b/Web/Types.hs
index 5878b64..3f55584 100644
--- a/Web/Types.hs
+++ b/Web/Types.hs
@@ -17,6 +17,7 @@ data LandingPageWithRecords = LandingPageWithRecords
{ landingPage :: !LandingPage
, paragraphCtas :: ![ParagraphCta]
, paragraphQuotes :: ![ParagraphQuote]
+ , paragraphHeroImages :: ![ParagraphHeroImage]
} deriving (Show)
{-| With the `FormStatus` we can show a message to the user after submitting a form,
@@ -64,6 +65,14 @@ data ParagraphQuotesController
| DeleteParagraphQuoteAction { paragraphQuoteId :: !(Id ParagraphQuote) }
deriving (Eq, Show, Data)
+data ParagraphHeroImagesController
+ = NewParagraphHeroImageAction { landingPageId :: !(Id LandingPage) }
+ | CreateParagraphHeroImageAction
+ | EditParagraphHeroImageAction { paragraphHeroImageId :: !(Id ParagraphHeroImage) }
+ | UpdateParagraphHeroImageAction { paragraphHeroImageId :: !(Id ParagraphHeroImage) }
+ | DeleteParagraphHeroImageAction { paragraphHeroImageId :: !(Id ParagraphHeroImage) }
+ deriving (Eq, Show, Data)
+
data ImageStyleController
diff --git a/Web/View/LandingPages/Edit.hs b/Web/View/LandingPages/Edit.hs
index 45d1e4f..c58bd48 100644
--- a/Web/View/LandingPages/Edit.hs
+++ b/Web/View/LandingPages/Edit.hs
@@ -16,7 +16,7 @@ data EditView = EditView
instance View EditView where
html EditView { .. } =
[ header
- , renderForm landingPage paragraphCtas paragraphQuotes formStatus
+ , renderForm landingPage paragraphCtas paragraphQuotes paragraphHeroImages formStatus
]
|> mconcat
|> wrapVerticalSpacing AlignNone
@@ -25,6 +25,7 @@ instance View EditView where
landingPage = landingPageWithRecords.landingPage
paragraphCtas = landingPageWithRecords.paragraphCtas
paragraphQuotes = landingPageWithRecords.paragraphQuotes
+ paragraphHeroImages = landingPageWithRecords.paragraphHeroImages
breadcrumb = renderBreadcrumb
[ breadcrumbLink "Landing Pages" LandingPagesAction
@@ -46,8 +47,8 @@ instance View EditView where
|> mconcat
|> wrapHorizontalSpacingTiny AlignBaseline
-renderForm :: LandingPage -> [ParagraphCta] -> [ParagraphQuote] -> FormStatus -> Html
-renderForm landingPage paragraphCtas paragraphQuotes formStatus = formFor landingPage body
+renderForm :: LandingPage -> [ParagraphCta] -> [ParagraphQuote] -> [ParagraphHeroImage] -> FormStatus -> Html
+renderForm landingPage paragraphCtas paragraphQuotes paragraphHeroImages formStatus = formFor landingPage body
where
body :: (?formContext :: FormContext LandingPage) => Html
body = [hsx|
@@ -68,7 +69,7 @@ renderForm landingPage paragraphCtas paragraphQuotes formStatus = formFor landin
[ addParagraphs
, [hsx|
- {orderAndRenderParagraphs paragraphCtas paragraphQuotes}
+ {orderAndRenderParagraphs paragraphCtas paragraphQuotes paragraphHeroImages}
|]
]
@@ -86,14 +87,16 @@ renderForm landingPage paragraphCtas paragraphQuotes formStatus = formFor landin
paragraphButtons =
[ renderButtonAction (NewParagraphCtaAction landingPage.id) "New CTA"
, renderButtonAction (NewParagraphQuoteAction landingPage.id) "New Quote"
+ , renderButtonAction (NewParagraphHeroImageAction landingPage.id) "New Hero Image"
]
|> mconcat
|> wrapHorizontalSpacing AlignCenter
-orderAndRenderParagraphs :: [ParagraphCta] -> [ParagraphQuote] -> Html
-orderAndRenderParagraphs paragraphCtas paragraphQuotes =
+orderAndRenderParagraphs :: [ParagraphCta] -> [ParagraphQuote] -> [ParagraphHeroImage] -> Html
+orderAndRenderParagraphs paragraphCtas paragraphQuotes paragraphHeroImages =
ctas
++ quotes
+ ++ heroImages
|> sortOn fst
|> fmap snd
|> mconcat
@@ -104,6 +107,9 @@ orderAndRenderParagraphs paragraphCtas paragraphQuotes =
quotes = paragraphQuotes
|> fmap (\paragraph -> (paragraph.weight, paragraphTitleAndOps EditParagraphQuoteAction DeleteParagraphQuoteAction paragraph.id paragraph.subtitle ("Quote" :: Text)))
+
+ heroImages = paragraphHeroImages
+ |> fmap (\paragraph -> (paragraph.weight, paragraphTitleAndOps EditParagraphHeroImageAction DeleteParagraphHeroImageAction paragraph.id paragraph.title ("Hero Image" :: Text)))
@@ -136,7 +142,7 @@ orderAndRenderParagraphs paragraphCtas paragraphQuotes =
sortableHandle =
if
- length ctas + length quotes > 1
+ length ctas + length quotes + length heroImages > 1
then
[hsx|
diff --git a/Web/View/LandingPages/Show.hs b/Web/View/LandingPages/Show.hs
index 249688b..e5d726e 100644
--- a/Web/View/LandingPages/Show.hs
+++ b/Web/View/LandingPages/Show.hs
@@ -5,6 +5,7 @@ import Web.Element.ElementWrap
import Web.Element.Link
import Web.Element.Types
import Web.Element.Quote
+import Web.Element.HeroImage
import Web.Types
import Web.View.Prelude
@@ -43,7 +44,7 @@ instance View ShowView where
orderAndRenderParagraphs :: (?context::ControllerContext) => LandingPageWithRecords -> Html
orderAndRenderParagraphs landingPageWithRecords =
- ctas ++ quotes
+ ctas ++ quotes ++ heroImages
-- Order by weight.
|> sortOn fst
|> fmap snd
@@ -64,6 +65,13 @@ orderAndRenderParagraphs landingPageWithRecords =
)
)
+ heroImages = landingPageWithRecords.paragraphHeroImages
+ |> fmap (\paragraph ->
+ ( paragraph.weight
+ , renderParagraphHeroImage paragraph
+ )
+ )
+
renderParagraphCta :: ParagraphCta -> Html
renderParagraphCta paragraphCta =
RenderCta
@@ -84,4 +92,13 @@ renderParagraphQuote paragraphQuote =
, subtitle = paragraphQuote.subtitle
, imageUrl = paragraphQuote.imageUrl |> fromMaybe ""
}
- |> Web.Element.Quote.render
\ No newline at end of file
+ |> Web.Element.Quote.render
+
+renderParagraphHeroImage :: ParagraphHeroImage -> Html
+renderParagraphHeroImage paragraphHeroImage =
+ RenderHeroImage
+ { title = paragraphHeroImage.title
+ , subtitle = paragraphHeroImage.subtitle |> fromMaybe ""
+ , imageUrl = paragraphHeroImage.imageUrl |> fromMaybe ""
+ }
+ |> Web.Element.HeroImage.render
\ No newline at end of file
diff --git a/Web/View/ParagraphCtas/Edit.hs b/Web/View/ParagraphCtas/Edit.hs
index 89b65f2..eaac7ab 100644
--- a/Web/View/ParagraphCtas/Edit.hs
+++ b/Web/View/ParagraphCtas/Edit.hs
@@ -32,7 +32,7 @@ renderForm paragraphCta landingPages = formFor paragraphCta [hsx|
[hsx|
{(textField #title) {required = True}}
{(textareaField #body) {required = True}}
- {(selectField #refLandingPageId landingPages) {required = True, fieldLabel = "Landing page", helpText = "Select the landing page you want to link to."}}
+ {(selectField #refLandingPageId landingPages) {required = True, fieldLabel = "Landing page", helpText = "Select the landing page you want to link to."}}
{submitButton}
|]
|> wrapVerticalSpacing AlignNone
diff --git a/Web/View/ParagraphCtas/New.hs b/Web/View/ParagraphCtas/New.hs
index af7059b..28432f6 100644
--- a/Web/View/ParagraphCtas/New.hs
+++ b/Web/View/ParagraphCtas/New.hs
@@ -31,7 +31,7 @@ renderForm paragraphCta landingPages = formFor paragraphCta [hsx|
[hsx|
{(textField #title) {required = True}}
{(textareaField #body) {required = True}}
- {(selectField #refLandingPageId landingPages) {required = True, fieldLabel = "Landing page", helpText = "Select the landing page you want to link to."}}
+ {(selectField #refLandingPageId landingPages) {required = True, fieldLabel = "Landing page", helpText = "Select the landing page you want to link to."}}
{submitButton}
|]
|> wrapVerticalSpacing AlignNone
diff --git a/Web/View/ParagraphHeroImages/Edit.hs b/Web/View/ParagraphHeroImages/Edit.hs
new file mode 100644
index 0000000..e8f740c
--- /dev/null
+++ b/Web/View/ParagraphHeroImages/Edit.hs
@@ -0,0 +1,19 @@
+module Web.View.ParagraphHeroImages.Edit where
+import Web.View.Prelude
+import Web.View.ParagraphHeroImages.Form
+
+data EditView = EditView
+ { paragraphHeroImage :: ParagraphHeroImage
+ , formStatus :: FormStatus
+ }
+
+instance View EditView where
+ html EditView { .. } = [hsx|
+ {breadcrumb}
+
Edit Paragraph Hero Image
+ {renderForm paragraphHeroImage False formStatus}
+ |]
+ where
+ breadcrumb = renderBreadcrumb
+ [ breadcrumbText "Edit Hero Image"
+ ]
diff --git a/Web/View/ParagraphHeroImages/Form.hs b/Web/View/ParagraphHeroImages/Form.hs
new file mode 100644
index 0000000..8ac2308
--- /dev/null
+++ b/Web/View/ParagraphHeroImages/Form.hs
@@ -0,0 +1,37 @@
+module Web.View.ParagraphHeroImages.Form where
+
+import Web.View.Prelude
+import Web.Element.Types
+import Web.Element.ElementWrap
+import Web.Element.SubmitButton
+
+{-| When editing the form, the image input field isn't required.
+That is, the image itself is required, but since we've already uploaded one,
+when editing, we don't require re-uploading the same image.
+-}
+renderForm :: ParagraphHeroImage -> Bool -> FormStatus -> Html
+renderForm paragraphHeroImage isImageRequired formStatus = formFor paragraphHeroImage [hsx|
+ {(hiddenField #landingPageId)}
+ {(hiddenField #weight)}
+ {visibleForm paragraphHeroImage}
+ |]
+ where
+ visibleForm :: (?formContext :: FormContext ParagraphHeroImage) => ParagraphHeroImage -> Html
+ visibleForm paragraphHeroImage =
+ [hsx|
+ {(textField #title) {required = True}}
+ {(textField #subtitle) {required = True}}
+
+
+ {(fileField #imageUrl) {required = isImageRequired, additionalAttributes = [("accept", "image/*"), ("data-preview", "#imageUrlPreview")]}}
+
+
+
+
+ {renderSubmitButtonwithFormStatus submitButton formStatus}
+ |]
+ |> wrapVerticalSpacing AlignNone
+ |> wrapContainerWide
+
+
+
diff --git a/Web/View/ParagraphHeroImages/New.hs b/Web/View/ParagraphHeroImages/New.hs
new file mode 100644
index 0000000..95341af
--- /dev/null
+++ b/Web/View/ParagraphHeroImages/New.hs
@@ -0,0 +1,21 @@
+module Web.View.ParagraphHeroImages.New where
+import Web.View.Prelude
+import Web.View.ParagraphHeroImages.Form
+
+
+data NewView = NewView
+ { paragraphHeroImage :: ParagraphHeroImage
+ , formStatus :: FormStatus
+ }
+
+instance View NewView where
+ html NewView { .. } = [hsx|
+ {breadcrumb}
+
New Paragraph Hero Image
+ {renderForm paragraphHeroImage True formStatus}
+ |]
+ where
+ breadcrumb = renderBreadcrumb
+ [ breadcrumbText "New Hero Image"
+ ]
+