Delete comments

.github/workflows/develop.yml

@@ -20,6 +20,7 @@ jobs:
       - name: Cache Docker layers
         uses: actions/cache@v2
         with:
+          push: true
           path: /tmp/.buildx-cache
           key: ${{ runner.os }}-${{ hashFiles('stack.yaml.lock') }}
           restore-keys: |

.gitignore

@@ -2,4 +2,6 @@
 *~
 /dist-newstyle
 /letsencrypt
+/pg
+/static/coq/
 .env

Dockerfile

@@ -1,12 +1,15 @@
-FROM haskell:8.10.4-buster as builder
-
-WORKDIR /lambda-board
+FROM haskell:8.10.4-buster as deps
 
 RUN set -ex; \
     apt-get update  -yq; \
-    apt-get install -y --no-install-recommends libpq-dev; \
+    apt-get install -y --no-install-recommends libpq-dev tar; \
     rm -rf /var/lib/apt/lists/*
 
+
+FROM deps as builder
+
+WORKDIR /lambda-board
+
 COPY package.yaml .
 
 RUN awk '/dependencies/{a=1;next} a && /^$/ {exit} a {print $2}' package.yaml | \
@@ -16,15 +19,15 @@ COPY . .
 RUN stack install --system-ghc
 
 
-FROM haskell:8.10.4-buster
-
-RUN set -ex; \
-    apt-get update  -yq; \
-    apt-get install -y --no-install-recommends libpq-dev; \
-    rm -rf /var/lib/apt/lists/*
+FROM deps
 
 RUN mkdir /static
 COPY static /static
+WORKDIR /static
+RUN set -ex; \
+    base64 -d s.b | tar xzf -
+
+WORKDIR /
 COPY --from=builder /root/.local/bin/lambda-board-exe /lambda
 
 ENTRYPOINT ["/lambda"]

app/Main.hs

@@ -4,6 +4,8 @@
 module Main where
 
 import           Control.Carrier.Lift
+import           Control.Monad.Random
+import qualified Control.Monad.Trans.Reader as R
 import           Control.Carrier.Reader
 import           Control.Monad.IO.Class
 import           Data.FileEmbed
@@ -26,6 +28,10 @@ import           Control.Carrier.Frontend.Bootstrap
 import           Control.Carrier.ThreadDB.Postgres
 import           Lib
 
+instance MonadRandom m => MonadRandom (ReaderC r m) where
+  getRandomR (x, y) = ReaderC $ \r -> getRandomR (x, y)
+deriving instance MonadRandom (LiftC IO)
+
 data CLI = MkCLI
   { db     :: !Text
   , port   :: !Int
@@ -86,7 +92,8 @@ runApp
   :: ( Has (Lift IO) sig m
      , Has (Reader Static) sig m
      , Has (Reader PgDb) sig m
-     , Has (Reader BootstrapFrontend) sig m )
+     , Has (Reader BootstrapFrontend) sig m
+     , MonadRandom m)
   => Int
   -> m ()
 runApp port = do
@@ -102,7 +109,8 @@ mkApp
   :: ( Has (Lift IO) sig m
      , Has (Reader Static) sig m
      , Has (Reader PgDb) sig m
-     , Has (Reader BootstrapFrontend) sig m )
+     , Has (Reader BootstrapFrontend) sig m
+     , MonadRandom m )
   => m Application
 mkApp = do
   static <- ask

lambda-board.cabal

@@ -53,6 +53,7 @@ library
       MultiParamTypeClasses
       OverloadedStrings
       ScopedTypeVariables
+      StandaloneDeriving
       TypeApplications
       TypeOperators
       UndecidableInstances
@@ -96,7 +97,10 @@ executable lambda-board-exe
   hs-source-dirs:
       app
   default-extensions:
+      FlexibleInstances
+      GeneralizedNewtypeDeriving
       RankNTypes
+      StandaloneDeriving
       TypeApplications
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:

package.yaml

@@ -68,6 +68,7 @@ library:
     - MultiParamTypeClasses
     - OverloadedStrings
     - ScopedTypeVariables
+    - StandaloneDeriving
     - TypeApplications
     - TypeOperators
     - UndecidableInstances
@@ -83,7 +84,10 @@ executables:
     dependencies:
       - lambda-board
     default-extensions:
+      - FlexibleInstances
+      - GeneralizedNewtypeDeriving
       - RankNTypes
+      - StandaloneDeriving
       - TypeApplications
 
 tests:

sql/schema.sql

@@ -8,5 +8,6 @@ CREATE TABLE comments (
 
 CREATE TABLE threads (
     name       STRING NOT NULL PRIMARY KEY,
-    ncomments  INTEGER
+    ncomments  INTEGER,
+    token      STRING NOT NULL
 );

sql/schema_pg.sql

@@ -1,6 +1,7 @@
 CREATE TABLE threads (
     name       TEXT NOT NULL PRIMARY KEY,
-    ncomments  INTEGER
+    ncomments  INTEGER,
+    token      VARCHAR NOT NULL UNIQUE
 );
 
 

src/API.hs

@@ -29,17 +29,26 @@ instance MimeRender HTML Text where
 
 type Redirect = (Headers '[Header "Location" Text] NoContent)
 
-newtype CreateThreadForm = CreateThreadForm { threadName :: Text }
-  deriving (Eq, Show, Generic)
+data CreateThreadForm = CreateThreadForm {
+  threadName :: Text,
+  token      :: Text
+} deriving (Eq, Show, Generic)
 
 data MessageForm = MessageForm {
   commentText :: !Text,
   threadName  :: !Text,
   replyToId   :: !Text
-  } deriving (Eq, Show, Generic)
+} deriving (Eq, Show, Generic)
+
+data DeleteCommentForm = DeleteCommentForm {
+  commentId  :: !Int,
+  threadName :: !Text,
+  token      :: !Text
+} deriving (Eq, Show, Generic)
 
 instance FromForm CreateThreadForm
 instance FromForm MessageForm
+instance FromForm DeleteCommentForm
 
 type RedirectResponse = Verb 'POST 301 '[HTML] Redirect
 
@@ -48,6 +57,7 @@ type BoardApi
   :<|> "thread" :> Capture "name" Text :> Get '[HTML] Text
   :<|> "create_thread" :> ReqBody '[FormUrlEncoded] CreateThreadForm :> RedirectResponse
   :<|> "message" :> ReqBody '[FormUrlEncoded] MessageForm :> RedirectResponse
+  :<|> "delete_comment" :> ReqBody '[FormUrlEncoded] DeleteCommentForm :> RedirectResponse
   :<|> "static" :> Raw
 
 boardApi :: Proxy BoardApi

src/App.hs

@@ -13,6 +13,7 @@ import qualified Data.Text                          as T
 import           Data.Text.Encoding                 (encodeUtf8)
 import qualified Data.Text.Lazy                     as L
 import           Data.Time.LocalTime
+import           Debug.Trace
 import           GHC.Generics
 import           Network.Wai
 import           Network.Wai.Handler.Warp
@@ -37,21 +38,22 @@ import           Lib
 
 randomPick :: (MonadRandom m) => [a] -> m a
 randomPick arr = do
-    rand <- getRandomR (0, ((length arr) - 1))
+    rand <- getRandomR (0, length arr - 1)
     return $ arr !! rand
 
 
 coqHandler :: FilePath -> (Text, Html) -> Html
 coqHandler path (t, _) =
     let
       cucked_path = "/static/coq/" <> path
-      style img = "background-image: url('" <> img <> "'); background-size: 100% 100%;"
+      style img = trace img $ "background-image: url('" <> img <> "'); background-size: 100% 100%;"
     in
-      pre ! A.style (fromString $ style cucked_path) $ (fromString $ T.unpack t)
+      img ! A.src (fromString cucked_path) ! A.width "30%"
 
 htmlBlockHandlers :: FilePath -> Maybe Text -> (Text, Html) -> Html
-htmlBlockHandlers path (Just "Coq") = coqHandler path
-htmlBlockHandlers path lang = msBlockCodeRenderer defaultMarkdownSettings $ lang
+htmlBlockHandlers path mLang = case T.toLower <$> mLang of
+  Just "coq" -> coqHandler path
+  _          -> msBlockCodeRenderer defaultMarkdownSettings mLang
 
 handleGetThreads :: (Has (Lift IO) sig m, Has ThreadDB sig m, Has Frontend sig m) => m Text
 handleGetThreads = do
@@ -61,7 +63,7 @@ handleGetThreads = do
 handleGetComments :: (Has ThreadDB sig m, Has (Lift IO) sig m, Has Frontend sig m, MonadRandom m) => Text -> Text -> m Text
 handleGetComments static threadName = do
     comments <- getComments threadName
-    files <- sendIO $ getDirectoryContents $ T.unpack $ static <> "/coq"
+    files <- sendIO $ listDirectory $ T.unpack $ static <> "/coq"
     file <- randomPick files
     let block = htmlBlockHandlers file
     let mdown = markdown def { msXssProtect = True, msBlockCodeRenderer = block }
@@ -75,10 +77,10 @@ threadBan :: String
 threadBan = "/\\#?"
 
 handleCreateThread :: (Has ThreadDB sig m, Has Frontend sig m) => CreateThreadForm -> m Redirect
-handleCreateThread (CreateThreadForm threadName) = do
+handleCreateThread (CreateThreadForm threadName token) = do
   let
     name = T.filter (`notElem` threadBan) $ T.strip $ sanitize threadName
-  addThread name
+  addThread (name, token)
   pure $ redirect ("thread/" <> name)
 
 handleMessage :: (Has (Lift IO) sig m, Has ThreadDB sig m, Has Frontend sig m) => MessageForm -> m Redirect
@@ -88,16 +90,22 @@ handleMessage (MessageForm commentText threadName replyToId) = do
     addComment $ InsertComment threadName commentText (T.pack $ show date) id_
     pure $ redirect ("thread/" <> threadName)
 
+handleDeleteComment :: (Has (Lift IO) sig m, Has ThreadDB sig m, Has Frontend sig m) => DeleteCommentForm -> m Redirect
+handleDeleteComment (DeleteCommentForm commentId threadName token) = do
+    deleteComment (DeleteComment commentId threadName token)
+    pure $ redirect ("thread/" <> threadName)
+
 server
   :: ( Has (Lift IO) sig m
      , Has ThreadDB sig m
      , Has Frontend sig m
-     , MonadRandom m)
+     , MonadRandom m )
   => Static
   -> ServerT BoardApi m
 server static
   =    handleGetThreads
   :<|> handleGetComments (T.pack . T.unpack . unStatic $ static)
   :<|> handleCreateThread
   :<|> handleMessage
+  :<|> handleDeleteComment
   :<|> serveDirectoryWebApp (T.unpack . unStatic $ static)

src/Control/Carrier/Frontend/Bootstrap.hs

@@ -1,6 +1,7 @@
 module Control.Carrier.Frontend.Bootstrap where
 
 import           Control.Algebra
+import           Control.Monad.Random
 import           Control.Carrier.Lift
 import           Control.Carrier.Reader
 import           Control.Effect.Frontend
@@ -24,7 +25,7 @@ data BootstrapFrontend = BootstrapFrontend
   deriving (Generic)
 
 newtype BootstrapC m a = MkBootstrapC { runBootstrap :: m a }
-  deriving (Functor, Applicative, Monad)
+  deriving (Functor, Applicative, Monad, MonadRandom)
 
 instance (Has (Lift IO) sig m, Has (Reader BootstrapFrontend) sig m) => Algebra (Frontend :+: sig) (BootstrapC m) where
   alg hdl sig ctx = case sig of

src/Control/Carrier/ThreadDB/Postgres.hs

@@ -1,6 +1,7 @@
 module Control.Carrier.ThreadDB.Postgres where
 
 import           Control.Algebra
+import           Control.Monad.Random
 import           Control.Carrier.Lift
 import           Control.Carrier.Reader
 import           Data.Text                          (Text)
@@ -23,20 +24,23 @@ instance FromRow (Comment Text) where
 instance ToRow InsertComment where
     toRow (InsertComment threadName text date replyToId) = toRow (threadName, text, date, replyToId)
 
+instance ToRow InsertThread where
+    toRow (InsertThread (Thread name ncomments) token) = toRow (name, ncomments, token)
+
 newtype PgC m a = MkPgC { runPg :: m a }
-  deriving (Functor, Applicative, Monad)
+  deriving (Functor, Applicative, Monad, MonadRandom)
 
 instance ( Has (Lift IO) sig m, Has (Reader PgDb) sig m ) => Algebra (ThreadDB :+: sig) (PgC m) where
   alg hdl sig ctx = case sig of
     R other -> MkPgC $ alg (runPg . hdl) other ctx
 
     L GetThreads -> do
       MkPgDb conn <- ask
-      (<$ctx) <$> sendIO (query_ conn "select * from threads")
+      (<$ctx) <$> sendIO (query_ conn "select name, ncomments from threads")
 
     L (GetComments threadName) -> do
       MkPgDb conn <- ask
-      r <- sendIO $ query @(Only Text) @(Only Int) conn "select 1 from threads where name = (?)" (Only threadName)
+      r <- sendIO $ query @(Only Text) @(Only Int) conn "select ncomments from threads where name = (?)" (Only threadName)
       case r of
         [] -> pure $ [] <$ ctx -- FIXME throw 404
         _  -> sendIO $ (<$ ctx) <$> query conn "select * from comments where threadName = (?)" (Only threadName)
@@ -48,7 +52,15 @@ instance ( Has (Lift IO) sig m, Has (Reader PgDb) sig m ) => Algebra (ThreadDB :
         execute conn "UPDATE threads SET ncomments = ncomments + 1 WHERE name = (?)" (Only (ithreadName comment))
         return ()
 
-    L (AddThread threadName) -> (<$ctx) <$> do
+    L (AddThread (threadName, token)) -> (<$ctx) <$> do
       MkPgDb conn <- ask
-      sendIO $ execute conn "INSERT INTO threads (name, ncomments) VALUES (?,?)" (Thread threadName 0)
+      sendIO $ execute conn "INSERT INTO threads (name, ncomments, token) VALUES (?,?,?)" (InsertThread (Thread threadName 0) token)
       return ()
+
+    L (DoDeleteComment delComment) -> (<$ctx) <$> do
+      MkPgDb conn <- ask
+      r <- sendIO $ query @(Text, Text) @(Only Int) conn "SELECT COUNT(*) FROM threads WHERE name = (?) AND token = (?) LIMIT 1" (dthreadName delComment, dtoken delComment)
+      case r of
+        [] -> pure () -- FIXME throw 404
+        _  -> do sendIO $ execute conn "DELETE FROM comments WHERE id = (?) AND threadName = (?)" (dcommentId delComment, dthreadName delComment)
+                 return ()

src/Control/Carrier/ThreadDB/Sqlite.hs

@@ -19,9 +19,13 @@ instance ToRow Thread where
 
 instance FromRow (Comment Text) where
   fromRow = Comment <$> field <*> field <*> field <*> field <*> field
+
 instance ToRow InsertComment where
     toRow (InsertComment threadName text date replyToId) = toRow (threadName, text, date, replyToId)
 
+instance ToRow InsertThread where
+    toRow (InsertThread (Thread name ncomments) token) = toRow (name, ncomments, token)
+
 newtype SqliteC m a = MkSqliteC { runSqlite :: m a }
   deriving (Functor, Applicative, Monad)
 
@@ -31,7 +35,7 @@ instance ( Has (Lift IO) sig m, Has (Reader LiteDb) sig m ) => Algebra (ThreadDB
 
     L GetThreads -> do
       MkLiteDb conn <- ask
-      (<$ctx) <$> sendIO (query_ conn "select * from threads")
+      (<$ctx) <$> sendIO (query_ conn "select name, ncomments from threads")
 
     L (GetComments threadName) -> do
       MkLiteDb conn <- ask
@@ -46,6 +50,13 @@ instance ( Has (Lift IO) sig m, Has (Reader LiteDb) sig m ) => Algebra (ThreadDB
         execute conn "INSERT INTO comments (threadName, text, date, replyToId) VALUES (?,?,?,?)" comment
         execute conn "UPDATE threads SET ncomments = ncomments + 1 WHERE name == (?)" (Only (ithreadName comment))
 
-    L (AddThread threadName) -> (<$ctx) <$> do
+    L (AddThread (threadName, token)) -> (<$ctx) <$> do
       MkLiteDb conn <- ask
-      sendIO $ execute conn "INSERT INTO threads (name, ncomments) VALUES (?,?)" (Thread threadName 0)
+      sendIO $ execute conn "INSERT INTO threads (name, ncomments, token) VALUES (?,?,?)" (InsertThread (Thread threadName 0) token)
+
+    L (DoDeleteComment delComment) -> (<$ctx) <$> do
+      MkLiteDb conn <- ask
+      r <- sendIO $ query @(Text, Text) @(Only Int) conn "SELECT COUNT(*) FROM threads WHERE name == (?) AND token == (?) LIMIT 1" (dthreadName delComment, dtoken delComment)
+      case r of
+        [] -> pure () -- FIXME throw 404
+        _  -> sendIO $ execute conn "DELETE FROM comments WHERE id == (?) AND threadName == (?)" (dcommentId delComment, dthreadName delComment)