Attempt to fix the connection bug I'm experiencing

backend/Dockerfile

@@ -7,9 +7,4 @@ COPY ./backend.cabal /opt/backend
 RUN cabal build --only-dependencies -j4
 COPY . /opt/backend
 RUN cabal install
-
+CMD ["backend"]
-FROM debian:buster
-RUN apt-get update
-RUN yes | apt-get install postgresql libpq-dev
-COPY --from=build /root/.cabal/bin/backend ./
-CMD ["./backend"]

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 ()
+createPostgreSQLConnection :: String -> String -> String -> String -> IO Connection
-appMain = do
+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 ()
+    r <- handleTakeResource pool $ 
-main = do
+      \c -> msum  [ dir "post" $ path $ \pid -> require (getPostContent c pid) $ \post -> ok $ toResponse post
-  result <- try appMain :: IO (Either SomeException ())
+                  , dir "category" $ path $ \cid -> do
-  case result of
+                      page <- look "page"
-    Left _ -> main
+                      let p = read page :: Int
-    Right _ -> return ()
+                      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 

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

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

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