Encode JSON example

Application/Helper/Controller.hs

@@ -46,4 +46,5 @@ 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
+

Application/Schema.sql

@@ -38,6 +38,11 @@ CREATE TABLE paragraph_ctas (
     body TEXT NOT NULL,
     ref_landing_page_id UUID DEFAULT uuid_generate_v4() NOT NULL
 );
+CREATE TABLE posts (
+    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
+    title TEXT NOT NULL,
+    body TEXT NOT NULL
+);
 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);
 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;

Web/Controller/Posts.hs

@@ -0,0 +1,65 @@
+module Web.Controller.Posts where
+
+import Web.Controller.Prelude
+import Web.View.Posts.Index
+import Web.View.Posts.New
+import Web.View.Posts.Edit
+import Web.View.Posts.Show
+
+instance Controller PostsController where
+    action PostsAction = do
+        posts <- query @Post |> fetch
+
+        -- Send posts also as JSON, so they can be printed in the console.
+        let postsJson = postsToJson posts
+
+        render IndexView { .. }
+
+    action NewPostAction = do
+        let post = newRecord
+        render NewView { .. }
+
+    action ShowPostAction { postId } = do
+        post <- fetch postId
+        render ShowView { .. }
+
+    action EditPostAction { postId } = do
+        post <- fetch postId
+        render EditView { .. }
+
+    action UpdatePostAction { postId } = do
+        post <- fetch postId
+        post
+            |> buildPost
+            |> ifValid \case
+                Left post -> render EditView { .. }
+                Right post -> do
+                    post <- post |> updateRecord
+                    setSuccessMessage "Post updated"
+                    redirectTo EditPostAction { .. }
+
+    action CreatePostAction = do
+        let post = newRecord @Post
+        post
+            |> buildPost
+            |> ifValid \case
+                Left post -> render NewView { .. }
+                Right post -> do
+                    post <- post |> createRecord
+                    setSuccessMessage "Post created"
+                    redirectTo PostsAction
+
+    action DeletePostAction { postId } = do
+        post <- fetch postId
+        deleteRecord post
+        setSuccessMessage "Post deleted"
+        redirectTo PostsAction
+
+buildPost post = post
+    |> fill @'["title", "body"]
+
+postsToJson :: [Post] -> Value
+postsToJson posts =
+    posts
+    |> fmap (\post -> object [ "id" .= post.id, "title" .= post.title, "body" .= post.body ])
+    |> toJSON

Web/FrontController.hs

@@ -6,6 +6,7 @@ import Web.View.Layout (defaultLayout)
 
 
 -- Controller Imports
+import Web.Controller.Posts
 import Web.Controller.Users
 import Web.Controller.ImageStyle
 import Web.Controller.LandingPages
@@ -19,6 +20,7 @@ instance FrontController WebApplication where
     controllers =
         [ startPage LandingPagesAction
         -- Generator Marker
+        , parseRoute @PostsController
         , parseRoute @UsersController
         , parseRoute @ImageStyleController
         , parseRoute @LandingPagesController

Web/Routes.hs

@@ -20,3 +20,6 @@ instance AutoRoute SessionsController
 
 instance AutoRoute UsersController
 
+
+instance AutoRoute PostsController
+

Web/Types.hs

@@ -77,3 +77,13 @@ data UsersController
     | UpdateUserAction { userId :: !(Id User) }
     | DeleteUserAction { userId :: !(Id User) }
     deriving (Eq, Show, Data)
+
+data PostsController
+    = PostsAction
+    | NewPostAction
+    | ShowPostAction { postId :: !(Id Post) }
+    | CreatePostAction
+    | EditPostAction { postId :: !(Id Post) }
+    | UpdatePostAction { postId :: !(Id Post) }
+    | DeletePostAction { postId :: !(Id Post) }
+    deriving (Eq, Show, Data)

Web/View/Posts/Edit.hs

@@ -0,0 +1,24 @@
+module Web.View.Posts.Edit where
+import Web.View.Prelude
+
+data EditView = EditView { post :: Post }
+
+instance View EditView where
+    html EditView { .. } = [hsx|
+        {breadcrumb}
+        <h1>Edit Post</h1>
+        {renderForm post}
+    |]
+        where
+            breadcrumb = renderBreadcrumb
+                [ breadcrumbLink "Posts" PostsAction
+                , breadcrumbText "Edit Post"
+                ]
+
+renderForm :: Post -> Html
+renderForm post = formFor post [hsx|
+    {(textField #title)}
+    {(textField #body)}
+    {submitButton}
+
+|]

Web/View/Posts/Index.hs

@@ -0,0 +1,49 @@
+module Web.View.Posts.Index where
+import Web.View.Prelude
+import Data.Aeson (encode, Value)
+
+data IndexView = IndexView
+    { posts :: [Post]
+    , postsJson :: Data.Aeson.Value
+    }
+
+instance View IndexView where
+    html IndexView { .. } = [hsx|
+        {breadcrumb}
+
+        <h1>Index<a href={pathTo NewPostAction} class="btn btn-primary ms-4">+ New</a></h1>
+        <div class="table-responsive">
+            <table class="table">
+                <thead>
+                    <tr>
+                        <th>Post</th>
+                        <th></th>
+                        <th></th>
+                        <th></th>
+                    </tr>
+                </thead>
+                <tbody>{forEach posts renderPost}</tbody>
+            </table>
+
+            {- Pass the encoded JSON to the JS script -}
+            <script data-posts={encode postsJson}>
+                // Parse the encoded JSON.
+                console.log(JSON.parse(document.currentScript.dataset.posts));
+            </script>
+
+        </div>
+    |]
+        where
+            breadcrumb = renderBreadcrumb
+                [ breadcrumbLink "Posts" PostsAction
+                ]
+
+renderPost :: Post -> Html
+renderPost post = [hsx|
+    <tr>
+        <td>{post}</td>
+        <td><a href={ShowPostAction post.id}>Show</a></td>
+        <td><a href={EditPostAction post.id} class="text-muted">Edit</a></td>
+        <td><a href={DeletePostAction post.id} class="js-delete text-muted">Delete</a></td>
+    </tr>
+|]

Web/View/Posts/New.hs

@@ -0,0 +1,24 @@
+module Web.View.Posts.New where
+import Web.View.Prelude
+
+data NewView = NewView { post :: Post }
+
+instance View NewView where
+    html NewView { .. } = [hsx|
+        {breadcrumb}
+        <h1>New Post</h1>
+        {renderForm post}
+    |]
+        where
+            breadcrumb = renderBreadcrumb
+                [ breadcrumbLink "Posts" PostsAction
+                , breadcrumbText "New Post"
+                ]
+
+renderForm :: Post -> Html
+renderForm post = formFor post [hsx|
+    {(textField #title)}
+    {(textField #body)}
+    {submitButton}
+
+|]

Web/View/Posts/Show.hs

@@ -0,0 +1,17 @@
+module Web.View.Posts.Show where
+import Web.View.Prelude
+
+data ShowView = ShowView { post :: Post }
+
+instance View ShowView where
+    html ShowView { .. } = [hsx|
+        {breadcrumb}
+        <h1>Show Post</h1>
+        <p>{post}</p>
+
+    |]
+        where
+            breadcrumb = renderBreadcrumb
+                            [ breadcrumbLink "Posts" PostsAction
+                            , breadcrumbText "Show Post"
+                            ]