Started to implement most of the server side functionality

README.md

@@ -4,12 +4,4 @@ This is a highly work-in-progress blog frontend and backend written in Haskell a
 
 Currently the only functionality that exists is providing a really bad card view of the posts that exist.
 
-You will need to create a table called posts manually if you want to use this, the following is necessary
-
-```sql
-CREATE TABLE posts(title varchar(128), subtext varchar(128), category varchar(128));
-```
-
-And you will need to add any entries manually.
-
 Exposed on port 80

backend/app/Main.hs

@@ -6,6 +6,12 @@ import Control.Exception
 import Database.HDBC
 import Database.HDBC.PostgreSQL (connectPostgreSQL)
 import Text.JSON
+import Data.ByteString.Char8 as C (pack)
+import Data.ByteString.Lazy.Char8 as L (pack)
+
+instance ToMessage JSValue where
+  toContentType _ = C.pack "application/json"
+  toMessage = \j -> L.pack $ encode j
 
 config = Conf {
   port = 80,
@@ -15,17 +21,93 @@ config = Conf {
   threadGroup = Nothing
 }
 
-getPostListing c = do
+getCategory :: IConnection t => t -> Int -> IO String
-  select <- prepare c "SELECT * FROM posts;"
+getCategory c category = do
-  execute select []
+  getCategory <- prepare c "SELECT name FROM categories WHERE catid = ?;"
-  result <- fetchAllRows select
+  execute getCategory [toSql category]
-  let posts = JSArray $ (map (\(t:s:c:[]) -> let (title, subtext, category) = (fromSql t, fromSql s, fromSql c) in showJSON $ toJSObject [("title", toJSString title), ("subtext", toJSString subtext), ("category", toJSString category)]) result) in
+  result <- fetchAllRows getCategory
-    return $ Just $ encode posts
+  case result of
+    (r:[]):[] -> return $ fromSql r;
+    _ -> fail "More than one category with same ID!"
+
+getPostListing :: IConnection t => t -> Int -> IO (Maybe JSValue)
+getPostListing c page = do
+  getPosts <- prepare c "SELECT * FROM posts ORDER BY postid DESC LIMIT 20 OFFSET (? * 20);"
+  execute getPosts [toSql (page)]
+  result <- fetchAllRows getPosts
+
+  posts <- sequence $
+    map (\(pid:cid:t:subtext:content:[]) -> do 
+    category <- getCategory c $ fromSql cid
+    let title = ("title", toJSString $ fromSql t)
+    let sub = ("subtext", toJSString $ fromSql subtext)
+    let cat = ("category", toJSString category)
+    let id = ("id", toJSString $ show $ (fromSql pid::Int))
+    return $ showJSON $ toJSObject [title, sub, cat]
+    ) result
+  return $ Just $ showJSON $ JSArray posts
+
+getCategoryListing :: IConnection t => t -> Int -> IO (Maybe JSValue)
+getCategoryListing c page = do
+  getCategories <- prepare c "SELECT * FROM categories ORDER BY catid DESC LIMIT 20 OFFSET (? * 20);"
+  execute getCategories [toSql (page)]
+  result <- fetchAllRows getCategories
+
+  categories <- sequence $
+    map (\(cid:n:[]) -> do
+    let id = ("id", toJSString $ show $ (fromSql cid::Int))
+    let name = ("name", toJSString $ fromSql n)
+    return $ showJSON $ toJSObject [id, name]
+    ) result
+  return $ Just $ showJSON $ JSArray categories
+
+getPostsInCategory :: IConnection t => t -> Int -> Int -> IO (Maybe JSValue)
+getPostsInCategory c cat page = do
+  getPosts <- prepare c "SELECT * FROM posts WHERE catid = ? ORDER BY postid DESC LIMIT 20 OFFSET (? * 20);"
+  execute getPosts [toSql cat, toSql page]
+  result <- fetchAllRows getPosts
+
+  category <- getCategory c cat
+
+  posts <- sequence $
+    map (\(pid:cid:t:subtext:content:[]) -> do
+    let title = ("title", toJSString $ fromSql t)
+    let sub = ("subtext", toJSString $ fromSql subtext)
+    let id = ("id", toJSString $ show $ (fromSql pid::Int))
+    return $ showJSON $ toJSObject [title, sub]
+    ) result
+  
+  return $ Just $ showJSON $ toJSObject [("category", showJSON $ toJSString category), ("posts", showJSON $ JSArray posts)]
+
+getPostContent :: IConnection t => t -> Int -> IO (Maybe JSValue)
+getPostContent c pid = do
+  getPost <- prepare c "SELECT title, catid, content FROM posts WHERE postid = ?;"
+  execute getPost [toSql (pid)]
+  result <- fetchAllRows getPost
+
+  case result of
+    (t:cid:con:[]):[] -> do
+      category <- getCategory c $ fromSql cid
+      let title = ("title", toJSString $ fromSql t)
+      let content = ("content", toJSString $ fromSql con)
+      let cat = ("category", toJSString category)
+      return $ Just $ showJSON $ toJSObject [title, content, cat];
+    _ -> fail "Post does not exist!"
 
 main :: IO ()
 main = do
   c <- connectPostgreSQL "host=database user=blog password=root dbname=blog"
+
+  createPostsTable <- prepare c "CREATE TABLE IF NOT EXISTS posts(postid serial primary key, catid int, title varchar(128), subtext varchar(128), content text);"
+  createCategoriesTable <- prepare c "CREATE TABLE IF NOT EXISTS categories(catid serial primary key, name varchar(128));"
+  execute createPostsTable []
+  execute createCategoriesTable []
+  commit c
+  
   simpleHTTP config $ 
-    msum [ dir "v1" $ path $ \s -> case s of {"posts" -> require (getPostListing c) $ \posts -> ok posts ; _ -> notFound "Endpoint does not exist"}
+    msum [ dir "v1" $ dir "post" $ path $ \pid -> require (getPostContent c pid) $ \post -> ok $ toResponse post
-         , notFound "Endpoint does not exist"
+         , dir "v1" $ dir "category" $ path $ \cid -> require (getPostsInCategory c cid 0) $ \cat -> ok $ toResponse cat
+         , dir "v1" $ dir "posts" $ require (getPostListing c 0) $ \posts -> ok $ toResponse posts
+         , dir "v1" $ dir "categories" $ require (getCategoryListing c 0) $ \cats -> ok $ toResponse cats
+         , notFound $ toResponse "Endpoint does not exist"
          ]

backend/backend.cabal

@@ -29,6 +29,6 @@ executable backend
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base ^>=4.14.3.0, happstack-server ^>=7.7.2, HDBC ^>= 2.4.0.4, HDBC-postgresql ^>= 2.3.2.4, json ^>= 0.10
+    build-depends:    base ^>=4.14.3.0, happstack-server ^>=7.7.2, HDBC ^>= 2.4.0.4, HDBC-postgresql ^>= 2.3.2.4, json ^>= 0.10, bytestring ^>= 0.10.12.0
     hs-source-dirs:   app
     default-language: Haskell2010

docker-compose.yml

@@ -6,6 +6,8 @@ services:
   
   backend:
     build: ./backend
+    depends_on: 
+      - database
   
   nginx:
     image: nginx:alpine

frontend/src/Main.elm

@@ -5,10 +5,11 @@ import Json.Decode exposing (Decoder, field, string, map3)
 
 import Browser
 import Browser.Navigation exposing (..)
-import Url 
+import Url
 import Html exposing (..)
 import Html.Attributes exposing (..)
 
+main : Program () Model Msg
 main =
   Browser.application { 
     init = init,