diff --git a/.github/workflows/develop.yml b/.github/workflows/develop.yml index 2dd968b..31ee901 100644 --- a/.github/workflows/develop.yml +++ b/.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: | diff --git a/.gitignore b/.gitignore index 9f12094..59b383b 100644 --- a/.gitignore +++ b/.gitignore @@ -2,4 +2,6 @@ *~ /dist-newstyle /letsencrypt +/pg +/static/coq/ .env diff --git a/Dockerfile b/Dockerfile index 576ffbf..999c0b6 100644 --- a/Dockerfile +++ b/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"] diff --git a/app/Main.hs b/app/Main.hs index 32250b6..f2fda8b 100644 --- a/app/Main.hs +++ b/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 diff --git a/lambda-board.cabal b/lambda-board.cabal index e761a05..87c20c6 100644 --- a/lambda-board.cabal +++ b/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: diff --git a/package.yaml b/package.yaml index 64571b2..63bc3f9 100644 --- a/package.yaml +++ b/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: diff --git a/sql/schema.sql b/sql/schema.sql index a8d032f..df13008 100644 --- a/sql/schema.sql +++ b/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 ); diff --git a/sql/schema_pg.sql b/sql/schema_pg.sql index 1262bf4..028895d 100644 --- a/sql/schema_pg.sql +++ b/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 ); diff --git a/src/API.hs b/src/API.hs index c18ae6c..5a3140d 100644 --- a/src/API.hs +++ b/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 diff --git a/src/App.hs b/src/App.hs index b5f1274..1caf19c 100644 --- a/src/App.hs +++ b/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,7 +38,7 @@ 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 @@ -45,13 +46,14 @@ 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,11 +90,16 @@ 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 @@ -100,4 +107,5 @@ server static :<|> handleGetComments (T.pack . T.unpack . unStatic $ static) :<|> handleCreateThread :<|> handleMessage + :<|> handleDeleteComment :<|> serveDirectoryWebApp (T.unpack . unStatic $ static) diff --git a/src/Control/Carrier/Frontend/Bootstrap.hs b/src/Control/Carrier/Frontend/Bootstrap.hs index 0b57499..0d5aba1 100644 --- a/src/Control/Carrier/Frontend/Bootstrap.hs +++ b/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 diff --git a/src/Control/Carrier/ThreadDB/Postgres.hs b/src/Control/Carrier/ThreadDB/Postgres.hs index a14df30..f53507a 100644 --- a/src/Control/Carrier/ThreadDB/Postgres.hs +++ b/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,8 +24,11 @@ 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 @@ -32,11 +36,11 @@ instance ( Has (Lift IO) sig m, Has (Reader PgDb) sig m ) => Algebra (ThreadDB : 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 () diff --git a/src/Control/Carrier/ThreadDB/Sqlite.hs b/src/Control/Carrier/ThreadDB/Sqlite.hs index 150fda2..f70ddaa 100644 --- a/src/Control/Carrier/ThreadDB/Sqlite.hs +++ b/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) diff --git a/src/Control/Effect/ThreadDB.hs b/src/Control/Effect/ThreadDB.hs index f65c595..eb2ab1e 100644 --- a/src/Control/Effect/ThreadDB.hs +++ b/src/Control/Effect/ThreadDB.hs @@ -6,11 +6,13 @@ import Data.Kind (Type) import Data.Text import Lib + data ThreadDB (m :: Type -> Type) k where - GetThreads :: ThreadDB m [Thread] - GetComments :: Text -> ThreadDB m [Comment Text] - AddThread :: Text -> ThreadDB m () - AddComment :: InsertComment -> ThreadDB m () + GetThreads :: ThreadDB m [Thread] + GetComments :: Text -> ThreadDB m [Comment Text] + AddThread :: (Text, Text) -> ThreadDB m () + AddComment :: InsertComment -> ThreadDB m () + DoDeleteComment :: DeleteComment -> ThreadDB m () getThreads :: Has ThreadDB sig m => m [Thread] getThreads = send GetThreads @@ -20,10 +22,14 @@ getComments :: Has ThreadDB sig m => Text -> m [Comment Text] getComments = send . GetComments {-# INLINE getComments #-} -addThread :: Has ThreadDB sig m => Text -> m () +addThread :: Has ThreadDB sig m => (Text, Text) -> m () addThread = send . AddThread {-# INLINE addThread #-} addComment :: Has ThreadDB sig m => InsertComment -> m () addComment = send . AddComment {-# INLINE addComment #-} + +deleteComment :: Has ThreadDB sig m => DeleteComment -> m () +deleteComment = send . DoDeleteComment +{-# INLINE deleteComment #-} diff --git a/src/Lib.hs b/src/Lib.hs index 5f86fdc..70e0056 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -31,9 +31,22 @@ data InsertComment = InsertComment { ireplyToId :: !(Maybe Int) } deriving (Eq, Show, Generic) +data DeleteComment = DeleteComment { + dcommentId :: !Int, + dthreadName :: !Text, + dtoken :: !Text +} deriving (Eq, Show, Generic) + +data InsertThread = InsertThread { + itthread :: !Thread, + ittoken :: !Text +} deriving (Eq, Show) instance ToJSON Thread instance FromJSON Thread instance ToJSON (Comment Text) instance FromJSON (Comment Text) + +instance ToJSON DeleteComment +instance FromJSON DeleteComment diff --git a/src/bootstrap_static/comments.html b/src/bootstrap_static/comments.html index 89bc21f..7ab6de6 100644 --- a/src/bootstrap_static/comments.html +++ b/src/bootstrap_static/comments.html @@ -8,8 +8,10 @@ + + - + - +

{{ title }}

@@ -32,12 +34,12 @@
Аноним
{{ comment.text }} - - + + {% endfor %}
- + diff --git a/src/bootstrap_static/main.js b/src/bootstrap_static/main.js new file mode 100644 index 0000000..ded948f --- /dev/null +++ b/src/bootstrap_static/main.js @@ -0,0 +1,76 @@ +var TOKEN_KEY = "token-" + +function onThreadsPageLoad() { + $("#form-create-thread").submit(function(eventObj) { + var token = generateToken(); + var name = $("#threadName").val() + setCookie(TOKEN_KEY+name, token, null) + $("").attr("type", "hidden") + .attr("name", "token") + .attr("value", token) + .appendTo("#form-create-thread"); + return true; + }); +} + +function onCommentsPageLoad() { + var threadName = $("#threadName").text() + var token = getCookie(TOKEN_KEY+threadName); + if (token) { + $(".comment-id").each(function() { + var e = $(this); + e.after( + "
" + + "" + + "" + + "" + + "" + + "
" + ); + }) + } + $("#form-delete-comment").submit(function(eventObj) { + var token = generateToken(); + $("").attr("type", "hidden") + .attr("name", "token") + .attr("value", token) + .appendTo("#form-delete-comment"); + return true; + }); +} + +function setCookie(name, value, days) { + var expires = ""; + if (days) { + var date = new Date(); + date.setTime(date.getTime() + (days*24*60*60*1000)); + expires = "; expires=" + date.toUTCString(); + } + document.cookie = name + "=" + (value || "") + expires + "; path=/"; +} + +function getCookie(name) { + var nameEQ = name + "="; + var ca = document.cookie.split(';'); + for(var i=0;i < ca.length;i++) { + var c = ca[i]; + while (c.charAt(0)==' ') c = c.substring(1,c.length); + if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length); + } + return null; +} + +function eraseCookie(name) { + document.cookie = name +'=; Path=/; Expires=Thu, 01 Jan 1970 00:00:01 GMT;'; +} + +function generateToken() { + var result = ''; + var characters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'; + var charactersLength = characters.length; + var length = 32; + for (var i = 0; i < length; i++) { + result += characters.charAt(Math.floor(Math.random() * charactersLength)); + } + return result; +} diff --git a/src/bootstrap_static/threads.html b/src/bootstrap_static/threads.html index 397ac54..da07f3c 100644 --- a/src/bootstrap_static/threads.html +++ b/src/bootstrap_static/threads.html @@ -8,8 +8,10 @@ + + - +