From ae917a1137ba190b8b7f426738c5c48e834664b0 Mon Sep 17 00:00:00 2001 From: Xnoe Date: Tue, 12 Jul 2022 21:18:33 +0100 Subject: [PATCH] Attempt to fix the connection bug I'm experiencing --- backend/Dockerfile | 7 +-- backend/app/Main.hs | 111 ++++++++++++++++++++++++++---------------- backend/backend.cabal | 2 +- docker-compose.yml | 2 - frontend/src/Main.elm | 2 +- 5 files changed, 72 insertions(+), 52 deletions(-) diff --git a/backend/Dockerfile b/backend/Dockerfile index ec68508..6325a54 100644 --- a/backend/Dockerfile +++ b/backend/Dockerfile @@ -7,9 +7,4 @@ COPY ./backend.cabal /opt/backend RUN cabal build --only-dependencies -j4 COPY . /opt/backend RUN cabal install - -FROM debian:buster -RUN apt-get update -RUN yes | apt-get install postgresql libpq-dev -COPY --from=build /root/.cabal/bin/backend ./ -CMD ["./backend"] \ No newline at end of file +CMD ["backend"] \ No newline at end of file diff --git a/backend/app/Main.hs b/backend/app/Main.hs index 6de489b..b26df8c 100644 --- a/backend/app/Main.hs +++ b/backend/app/Main.hs @@ -1,11 +1,12 @@ module Main where +import System.IO import Happstack.Server import Control.Monad import Control.Monad.Trans import Control.Exception import Database.HDBC -import Database.HDBC.PostgreSQL (connectPostgreSQL) +import Database.HDBC.PostgreSQL (connectPostgreSQL, Connection) import Text.JSON import Data.ByteString.Char8 as C (pack) import Data.ByteString.Lazy.Char8 as L (pack) @@ -13,6 +14,7 @@ import Data.ByteString as B (unpack, ByteString) import Text.Printf import System.Random (newStdGen, randomRs) import System.ReadEnvVar (lookupEnv) +import Data.Pool import Crypto.Hash.SHA256 as SHA256 @@ -316,8 +318,31 @@ handleWhoami c = do Just u -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true"), ("username", toJSString u)] Nothing -> ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "false"), ("username", toJSString "")] -appMain :: IO () -appMain = do +createPostgreSQLConnection :: String -> String -> String -> String -> IO Connection +createPostgreSQLConnection dbhost dbuser dbpass dbname = do + putStrLn "Connection Created" + hFlush stdout + connectPostgreSQL ("host=" ++ dbhost ++ " user=" ++ dbuser ++ " password=" ++ dbpass ++ " dbname=" ++ dbname) + +destroyPostgreSQLConnection :: IConnection t => t -> IO () +destroyPostgreSQLConnection c = do + putStrLn "Connection Destroyed" + hFlush stdout + disconnect c + +handleTakeResource :: IConnection conn => (Pool conn) -> (conn -> a) -> ServerPartT IO a +handleTakeResource pool f = do + lift $ putStrLn "Resource Taken From Pool." + lift $ hFlush stdout + (c, localpool) <- lift $ takeResource pool + let v = return $ f c + lift $ putResource localpool c + v + +main :: IO () +main = do + putStrLn "Starting!" + hFlush stdout dbhostvar <- lookupEnv "DB_HOST" dbuservar <- lookupEnv "DB_USER" dbpassvar <- lookupEnv "DB_PASS" @@ -345,7 +370,11 @@ appMain = do Just p -> p Nothing -> "" - c <- connectPostgreSQL ("host=" ++ dbhost ++ " user=" ++ dbuser ++ " password=" ++ dbpass ++ " dbname=" ++ dbname) + --c <- connectPostgreSQL ("host=" ++ dbhost ++ " user=" ++ dbuser ++ " password=" ++ dbpass ++ " dbname=" ++ dbname) + + pool <- newPool (PoolConfig {createResource = createPostgreSQLConnection dbhost dbuser dbpass dbname, freeResource = destroyPostgreSQLConnection, poolCacheTTL = 300, poolMaxResources = 20}) + + (c, localpool) <- takeResource pool 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));" @@ -371,44 +400,42 @@ appMain = do else do return () + putResource localpool c; + simpleHTTP config $ do decodeBody (defaultBodyPolicy "/tmp/" 0 4096 4096) - msum [ dir "post" $ path $ \pid -> require (getPostContent c pid) $ \post -> ok $ toResponse post - , dir "category" $ path $ \cid -> do - page <- look "page" - let p = read page :: Int - if (p < 0) then - ok $ toResponse "" - else - require (getPostsInCategory c cid p) $ \cat -> ok $ toResponse cat - , dir "posts" $ do - page <- look "page" - let p = read page :: Int - if (p < 0) then - ok $ toResponse "" - else - require (getPostListing c p) $ \posts -> ok $ toResponse posts - , dir "categories" $ do - page <- look "page" - let p = read page :: Int - if (p < 0) then - ok $ toResponse "" - else - require (getCategoryListing c p) $ \cats -> ok $ toResponse cats - , dir "login" $ handleLogin c - , dir "createPost" $ handleCreatePost c - , dir "whoami" $ handleWhoami c - , dir "logout" $ do - expireCookie "token" - ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true")] - , dir "editPost" $ handleEditPost c - , dir "deletePost" $ handleDeletePost c - , notFound $ toResponse "Endpoint does not exist" - ] -main :: IO () -main = do - result <- try appMain :: IO (Either SomeException ()) - case result of - Left _ -> main - Right _ -> return () \ No newline at end of file + r <- handleTakeResource pool $ + \c -> msum [ dir "post" $ path $ \pid -> require (getPostContent c pid) $ \post -> ok $ toResponse post + , dir "category" $ path $ \cid -> do + page <- look "page" + let p = read page :: Int + if (p < 0) then + ok $ toResponse "" + else + require (getPostsInCategory c cid p) $ \cat -> ok $ toResponse cat + , dir "posts" $ do + page <- look "page" + let p = read page :: Int + if (p < 0) then + ok $ toResponse "" + else + require (getPostListing c p) $ \posts -> ok $ toResponse posts + , dir "categories" $ do + page <- look "page" + let p = read page :: Int + if (p < 0) then + ok $ toResponse "" + else + require (getCategoryListing c p) $ \cats -> ok $ toResponse cats + , dir "login" $ handleLogin c + , dir "createPost" $ handleCreatePost c + , dir "whoami" $ handleWhoami c + , dir "logout" $ do + expireCookie "token" + ok $ toResponse $ showJSON $ toJSObject [("success", toJSString "true")] + , dir "editPost" $ handleEditPost c + , dir "deletePost" $ handleDeletePost c + , notFound $ toResponse "Endpoint does not exist" + ] + r \ No newline at end of file diff --git a/backend/backend.cabal b/backend/backend.cabal index a986278..02c9341 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, bytestring ^>= 0.10.12.0, cryptohash-sha256 ^>= 0.11.102.1, random ^>= 1.1, mtl ^>= 2.2.2, read-env-var ^>= 1.0.0.0 + 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, cryptohash-sha256 ^>= 0.11.102.1, random ^>= 1.1, mtl ^>= 2.2.2, read-env-var ^>= 1.0.0.0, resource-pool ^>= 0.3.1.0 hs-source-dirs: app default-language: Haskell2010 diff --git a/docker-compose.yml b/docker-compose.yml index 1b32979..cff81f7 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -10,8 +10,6 @@ services: restart: unless-stopped build: ./backend image: registry.xnopyt.com/xnoeblog-backend:latest - depends_on: - - database environment: - XNOEBLOG_USER=user - XNOEBLOG_PASS=password diff --git a/frontend/src/Main.elm b/frontend/src/Main.elm index 9dd64c5..82bb712 100644 --- a/frontend/src/Main.elm +++ b/frontend/src/Main.elm @@ -355,7 +355,7 @@ prod_list accl accs chars = '\n' -> prod_list (accl++[text accs, br [] []]) "" tl '\r' -> prod_list accl accs tl c -> prod_list (accl) (accs++(String.fromChar c)) tl - [] -> accl + [] -> accl++[text accs] parseContent : String -> List (Html Msg) parseContent content = let chars = String.toList content in