diff --git a/README.md b/README.md index ea11694..136a6f3 100644 --- a/README.md +++ b/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 \ No newline at end of file diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 2670098..3dd465f 100644 --- a/backend/app/Main.hs +++ b/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 - select <- prepare c "SELECT * FROM posts;" - execute select [] - result <- fetchAllRows select - 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 - return $ Just $ encode posts +getCategory :: IConnection t => t -> Int -> IO String +getCategory c category = do + getCategory <- prepare c "SELECT name FROM categories WHERE catid = ?;" + execute getCategory [toSql category] + result <- fetchAllRows getCategory + 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"} - , notFound "Endpoint does not exist" + msum [ dir "v1" $ dir "post" $ path $ \pid -> require (getPostContent c pid) $ \post -> ok $ toResponse post + , 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" ] diff --git a/backend/backend.cabal b/backend/backend.cabal index 6f67b6f..242397c 100644 --- a/backend/backend.cabal +++ b/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 diff --git a/docker-compose.yml b/docker-compose.yml index bac1251..7dea561 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -6,6 +6,8 @@ services: backend: build: ./backend + depends_on: + - database nginx: image: nginx:alpine diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index 7215f79..f3af671 100644 --- a/frontend/src/Main.elm +++ b/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,