Adding app state and delete feature

Author: soupi

src/Bulletin.hs

@@ -8,6 +8,8 @@ import Network.Wai.Handler.Warp (run, Port)
 import qualified Data.Text as T
 import qualified Data.Time.Clock as C
 import qualified Data.Map as M
+import qualified Control.Concurrent.STM as STM
+import Control.Monad.IO.Class (liftIO)
 
 -- | Entry point. Starts a bulletin-board server at port 3000.
 main :: IO ()
@@ -30,20 +32,23 @@ runServer port = do
 mkApp :: IO Twain.Application
 mkApp = do
   dummyPosts <- makeDummyPosts
+  appstateVar <- STM.newTVarIO AppState{asNextId = 1, asPosts = dummyPosts}
   pure $ foldr ($)
     (Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
-    (routes dummyPosts)
+    (routes appstateVar)
 
 -- | Bulletin board routing.
-routes :: Posts -> [Twain.Middleware]
-routes posts =
+routes :: STM.TVar AppState -> [Twain.Middleware]
+routes appstateVar =
   -- Our main page, which will display all of the bulletins
-  [ Twain.get "/" $
+  [ Twain.get "/" $ do
+    posts <- liftIO $ asPosts <$> STM.readTVarIO appstateVar
     Twain.send (displayAllPosts posts)
 
   -- A page for a specific post
   , Twain.get "/post/:id" $ do
     pid <- Twain.param "id"
+    posts <- liftIO $ asPosts <$> STM.readTVarIO appstateVar
     Twain.send (displayPost pid posts)
 
   -- A page for creating a new post
@@ -55,8 +60,10 @@ routes posts =
     Twain.send $ Twain.text "not yet implemented"
 
   -- A request to delete a specific post
-  , Twain.post "/post/:id/delete" $
-    Twain.send $ Twain.text "not yet implemented"
+  , Twain.post "/post/:id/delete" $ do
+    pid <- Twain.param "id"
+    response <- liftIO $ handleDeletePost pid appstateVar
+    Twain.send response
   ]
 
 -- ** Business logic
@@ -79,6 +86,30 @@ displayPost pid posts =
         [("Content-Type", "text/plain; charset=utf-8")]
         "404 Not found."
 
+-- | Delete a post and respond to the user.
+handleDeletePost :: Integer -> STM.TVar AppState -> IO Twain.Response
+handleDeletePost pid appstateVar = do
+  found <- deletePost pid appstateVar
+  pure $
+    if found
+      then
+        Twain.redirect302 "/"
+
+      else
+        Twain.raw
+          Twain.status404
+          [("Content-Type", "text/html; charset=utf-8")]
+          "404 Not Found."
+
+-- ** Application state
+
+-- | Application state.
+data AppState
+  = AppState
+    { asNextId :: Integer -- ^ The id for the next post
+    , asPosts :: Posts -- ^ All posts
+    }
+
 -- ** Posts
 
 -- | A mapping from a post id to a post.
@@ -129,3 +160,35 @@ ppPost post =
       , pContent post
       , seperator
       ]
+
+-- | Add a new post to the store.
+newPost :: Post -> STM.TVar AppState -> IO Integer
+newPost post appstateVar = do
+  STM.atomically $ do
+    appstate <- STM.readTVar appstateVar
+    STM.writeTVar
+      appstateVar
+      ( appstate
+        { asNextId = asNextId appstate + 1
+        , asPosts = M.insert (asNextId appstate) post (asPosts appstate)
+        }
+      )
+    pure (asNextId appstate)
+
+-- | Delete a post from the store.
+deletePost :: Integer -> STM.TVar AppState -> IO Bool
+deletePost pid appstateVar =
+  STM.atomically $ do
+    appstate <- STM.readTVar appstateVar
+    case M.lookup pid (asPosts appstate) of
+      Just{} -> do
+        STM.writeTVar
+          appstateVar
+          ( appstate
+            { asPosts = M.delete pid (asPosts appstate)
+            }
+          )
+        pure True
+
+      Nothing ->
+        pure False