guestbook reimplementation

.ghci

@@ -1,2 +1 @@
-:set prompt "[\ESC[38;2;255;100;0mHomepage dev\ESC[0m] > "
-:seti -fdiagnostics-color=auto
+:set prompt "[\ESC[38;2;255;100;0mHomepage dev\ESC[0m] > "

app/Api/Api.hs

@@ -1,7 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Api.Api where
 
-import Helpers.Database (getVisits, uuidExists, insert)
-import Helpers.Utils (unpackBS)
+
+import Helpers.Tables
+import Helpers.Database (getVisits, uuidExists, insert, getGuestbook)
+import Helpers.Utils (unpackBS, getDefault)
 
 import IHP.HSX.QQ (hsx)
 import Text.Blaze.Html (Html)
@@ -11,9 +15,21 @@ import Data.UUID.V4 (nextRandom)
 import Data.UUID (toString)
 
 import Network.Wai (getRequestBodyChunk, Request)
-import Network.HTTP.Types.Status (Status, status404, status200)
+import Network.HTTP.Types.Status (Status, status404, status200, status400)
+
+import Data.Aeson
+import Data.ByteString.Lazy (fromStrict, toStrict)
+import Control.Applicative
 
 
+handleGuestbookEntry :: GuestbookEntry -> IO (Status, String)
+handleGuestbookEntry (GuestbookEntry name content parentId) = do
+    time <- fmap round getPOSIXTime :: IO Int
+    insert "INSERT INTO guestbook (name, timestamp, content, parentId) values (?, ?, ?, ?)" (name :: String, time :: Int, content :: String, parentId :: Int)
+    return (status200, "Success")
+handleGuestbookEntry EmptyGuestbook = do
+    return (status400, "Error")
+
 api :: [String] -> Request -> IO (Status, String)
 api ["visits", "new"] request = do
     body <- getRequestBodyChunk request
@@ -29,5 +45,13 @@ api ["visits", "new"] request = do
 api ["visits", "get"] request = do
     visits <- show . length <$> getVisits
     return (status200, visits)
+api ["guestbook", "add"] request = do
+    body <- getRequestBodyChunk request
+    let entry = getDefault EmptyGuestbook (decode (fromStrict body) :: Maybe GuestbookEntry)
+    handleGuestbookEntry entry
+api ["guestbook", "get"] request = do
+    body <- getRequestBodyChunk request
+    entries <- getGuestbook
+    return (status200, unpackBS $ toStrict $ encode entries)
 api xs request = do
     return (status404, "{\"error\":\"Endpoint does not exist\"}")

app/Helpers/Database.hs

@@ -5,6 +5,7 @@ module Helpers.Database where
 import Database.SQLite.Simple (close, execute, open, query, Only(Only), ToRow, Query (Query), Connection)
 
 import Helpers.Globals (getDbPath)
+import Helpers.Tables
 
 import Data.List (intercalate, inits)
 import Data.Text (pack, Text)
@@ -27,6 +28,13 @@ getVisits = do
     close conn
     return visits
 
+getGuestbook :: IO [(Int, Int, String, String, Int)]
+getGuestbook = do
+    conn <- getConn
+    entries <- query conn "SELECT * FROM guestbook" () :: IO [(Int, Int, String, String, Int)]
+    close conn
+    return entries
+
 uuidExists :: String -> IO Bool
 uuidExists uuid = do
     conn <- getConn
@@ -48,7 +56,8 @@ schema = [
         Column "id" "INTEGER PRIMARY KEY",
         Column "timestamp" "INTEGER NOT NULL",
         Column "name" "VARCHAR NOT NULL",
-        Column "message" "VARCHAR NOT NULL"
+        Column "content" "VARCHAR NOT NULL",
+        Column "parentId" "INTEGER NOT NULL"
     ],
     Table "snake" [
         Column "id" "INTEGER PRIMARY KEY",

app/Helpers/Tables.hs

@@ -0,0 +1,28 @@
+module Helpers.Tables where
+
+import Data.Aeson
+import Data.ByteString.Lazy (fromStrict)
+import Control.Applicative
+
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromRow
+
+data GuestbookEntry = GuestbookEntry {
+    name :: String,
+    content :: String,
+    parent :: Int
+} | EmptyGuestbook
+    deriving Show
+
+instance FromJSON GuestbookEntry where
+    parseJSON (Object v) = GuestbookEntry <$>
+                           v .: "name" <*>
+                           v .: "content" <*>
+                           v .: "parentId"
+    parseJSON _          = empty
+
+instance ToJSON GuestbookEntry where
+    toJSON (GuestbookEntry name content parent) = object ["name" .= name, "content" .= content, "parent" .= parent]
+
+instance FromRow GuestbookEntry where
+    fromRow = GuestbookEntry <$> field <*> field <*> field

app/Helpers/Utils.hs

@@ -38,4 +38,9 @@ row values = [hsx|
 |]
 
 unpackBS :: ByteString -> String
-unpackBS = unpack . decodeUtf8
+unpackBS = unpack . decodeUtf8
+
+getDefault :: a -> Maybe a -> a
+getDefault def a = case a of
+    (Just v) -> v
+    Nothing -> def

app/Index.hs

@@ -27,7 +27,12 @@ intro = section [hsx|
     HSX is actually pretty cool, i just toss in html inline with haskell and it just works: 
     <br><br>
     {hsxIntroCodeBlock}
-    I had to do a little hack around the preprocessor to make it not compile that little snippet of code, and as such you won't see me show any more hsx code xD
+    I had to do a little hack around the preprocessor to make it not compile that little snippet of code, and as such you won't see me show any more hsx code xD<br>
+    Running the above code:
+    <br>
+    <div style="background-color: #222222">
+        {introCodeIndex}
+    </div>
 |]
 
 visitorCounter :: Html

app/Layout.hs

@@ -17,6 +17,7 @@ layout content = [hsx|
             ("Contact", "/contact"),
             ("Projects", "/projects"),
             ("Sources", "/sources"),
+            ("Guestbook", "/guestbook"),
             ("Old Site", "https://about.skademaskinen.win")
         ]}
         <title>Skademaskinen</title>

app/Main.hs

@@ -24,6 +24,7 @@ import Index (index)
 import Pages.Contact.Contact (contact)
 import Pages.Projects.Projects (projects)
 import Pages.Sources.Sources (sources)
+import Pages.Guestbook.Guestbook (guestbook)
 
 import Helpers.Database (initDb)
 import Helpers.Utils (unpackBS)
@@ -49,16 +50,19 @@ serveFile path = do
 
 
 handleRequest :: [String] -> Request ->  IO Response
-handleRequest ("static":xs) request = do serveFile $ intercalate "/" ("static":xs)
+handleRequest ("static":xs) request = serveFile $ intercalate "/" ("static":xs)
 handleRequest ("api":args) request = do
     (status, value) <- api args request
     return $ responseBuilder status [("Content-Type", "text/plain")] $ copyByteString (fromString value)
-handleRequest ["contact"] request = do return $ serve (layout contact)
-handleRequest ["sources"] request = do return $ serve (layout sources)
-handleRequest ("projects":project) request = do return $ serve (layout (projects project))
+handleRequest ["contact"] request = return $ serve (layout contact)
+handleRequest ["sources"] request = return $ serve (layout sources)
+handleRequest ["guestbook"] request = do
+    page <- guestbook
+    return $ serve (layout page)
+handleRequest ("projects":project) request = return $ serve (layout (projects project))
 handleRequest ["favicon.ico"] request = do serveFile "static/favicon.ico"
-handleRequest [] request = do return $ serve (layout index)
-handleRequest x request = do return $ page404 x
+handleRequest [] request = return $ serve (layout index)
+handleRequest x request = return $ page404 x
 
 colorStatus :: Int -> String
 colorStatus code | code < 300 = "\ESC[38;2;0;255;0m"++show code++"\ESC[0m"

app/Pages/Guestbook/Guestbook.hs

@@ -0,0 +1,95 @@
+module Pages.Guestbook.Guestbook where
+
+import IHP.HSX.QQ (hsx)
+import Text.Blaze.Html (Html)
+
+import Helpers.Database (getGuestbook)
+import Helpers.Section (section)
+
+import Data.List (filter)
+
+import Data.Time.Format.ISO8601
+import Data.Time.Format
+import Data.Time.Clock.POSIX
+
+type Guestbook = [(Int, Int, String, String, Int)]
+
+toPosix :: Int -> POSIXTime
+toPosix n = read ((show n) ++ "s") :: POSIXTime
+
+prettify_guestbook :: Guestbook -> Html
+prettify_guestbook ((id, timestamp, name, content, parent):xs) = mconcat [section [hsx|
+    <h3>{name} said: </h3>
+    <div style="background-color: #111111; border: 1px solid #111111; border-radius: 5px;">
+        id: <span style="color: #ff0000">{id}</span> 
+        parent: <span style="color: #ff0000">{parent}</span> 
+        timestamp: <span style="color: #ff0000">{formatTime defaultTimeLocale "%c" $ posixSecondsToUTCTime (toPosix timestamp)}</span>
+        <br><br>
+        {content}
+    </div>
+    {prettify_guestbook $ children} 
+    {guestbook_input id True}
+    <br><br>
+|], prettify_guestbook rest]
+    where
+        children :: Guestbook
+        children = filter (\(_, _, _, _, childParent) -> childParent == id) xs
+        rest :: Guestbook
+        rest = filter (\(_, _, _, _, childParent) -> childParent /= id) xs
+prettify_guestbook [] = [hsx||]
+
+guestbook_input :: Int -> Bool -> Html
+guestbook_input parent False = [hsx|
+    <textarea class="guestbook-text" id={"guestbook-text::"++show parent} type="text"></textarea>
+    <br>
+    Name: <input id={"guestbook-name::"++show parent} class="guestbook-name" type="text">
+    <button id={show parent} onclick="post(this.id)">Post</button>
+|]
+guestbook_input parent True = [hsx|
+    <button id={show parent} onclick="guestbookToggleInput(this.id)">New reply</button>
+    <br>
+    <div style="display:none;" id={"guestbook-reply::"++show parent}>
+        {guestbook_input parent False}
+    </div>
+|]
+
+guestbook :: IO Html
+guestbook = do
+    guestbook <- getGuestbook
+    return [hsx|
+        <script>
+            function guestbookToggleInput(id) {
+                var reply = document.getElementById("guestbook-reply::"+id)
+                if(reply.style.display == "none") {
+                    reply.style.display = "unset"
+                }
+                else {
+                    reply.style.display = "none"
+                }
+            }
+            function post(id) {
+                var text = document.getElementById("guestbook-text::"+id).value
+                var name = document.getElementById("guestbook-name::"+id).value
+                console.log(id)
+                fetch("/api/guestbook/add", {
+                    method:"POST",
+                    body: JSON.stringify({
+                        name: name,
+                        content: text,
+                        parentId: Number(id)
+                    })
+                }).then(response => {
+                    if(response.status == 200){
+                        window.location.reload()
+                    }
+                })
+            }
+        </script>
+        <h1>Guestbook</h1>
+        Write a message for me :)<br>
+        {guestbook_input (-1) False}
+        <hr>
+        <h2>History</h2>
+        {prettify_guestbook guestbook}
+    |]
+