Commit 01218ec6 authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

replied.

parent 3dbd3965
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 8146799c97967808e50779a0ee879c0e0efa4025b3146f3a23d42319258bc009
-- hash: 1d9998cdd2c8dffb4e1bb34c7eb073bac9a64a60f464255c172e5cce723b6908
name: Cirkeltrek
version: 0.0.0
......@@ -20,6 +20,7 @@ library
Flux.AdmForum
Flux.Forum
Flux.Home
Flux.Post
Flux.Topic
Foundation
Handler.Adm.Category
......@@ -27,6 +28,7 @@ library
Handler.Forum
Handler.Home
Handler.Profile
Handler.Topic
Import
Import.NoFoundation
Import.Util
......
......@@ -30,6 +30,7 @@ import Handler.Profile
import Handler.Adm.Category
import Handler.Adm.Forum
import Handler.Forum
import Handler.Topic
mkYesodDispatch "App" resourcesApp
......
......@@ -7,7 +7,7 @@
module DBOp.CRUDForum where
import Import hiding (Value, groupBy, on,
(==.))
update, (+=.), (=.), (==.))
import Database.Esqueleto
import Database.Esqueleto.PostgreSQL
......@@ -86,3 +86,21 @@ selectForumById fid = do
where_ (forum ^. ForumsId ==. val fid)
limit 1
return forum
updateForumIncrementReplyAndLasts ::
MonadIO m
=> Key Forums
-> Text
-> Key Posts
-> UTCTime
-> ReaderT SqlBackend m ()
updateForumIncrementReplyAndLasts fid username pid last = do
update $ \forum -> do
set
forum
[ ForumsRepliesCount +=. (val 1)
, ForumsLastPoster =. (val $ Just username)
, ForumsLastPostId =. (val $ Just pid)
, ForumsLastPost =. (val $ Just last)
]
where_ (forum ^. ForumsId ==. val fid)
......@@ -8,7 +8,7 @@
module DBOp.CRUDPost where
import Import hiding (Value, groupBy, on,
(==.))
update, (=.), (==.))
import Database.Esqueleto
import Database.Esqueleto.PostgreSQL
......@@ -30,3 +30,21 @@ insertPost tid number username userid content = do
postsTime = now
postsContent = content
insert Posts {..}
selectPostByTopicId ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Topics
-> Int64
-> ReaderT backend m [Entity Posts]
selectPostByTopicId tid page = do
select $
from $ \post -> do
where_ (post ^. PostsTopicId ==. val tid)
orderBy [asc (post ^. PostsNumber)]
offset ((page - 1) * 25)
limit 25
return post
......@@ -8,7 +8,7 @@
module DBOp.CRUDTopic where
import Import hiding (Value, groupBy, on,
update, (=.), (==.))
update, (+=.), (=.), (==.))
import Database.Esqueleto
import Database.Esqueleto.PostgreSQL
......@@ -32,13 +32,41 @@ insertTopic fid poster subject = do
topicsIsLocked = False
insert Topics {..}
selectTopicById ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Topics
-> ReaderT backend m [Entity Topics]
selectTopicById tid = do
select $ from $ \topic -> do
where_ (topic ^. TopicsId ==. val tid)
limit 1
return topic
updateTopicIsLocked ::
MonadIO m => Key Topics -> Bool -> ReaderT SqlBackend m ()
updateTopicIsLocked tid locked = do
update $ \topic -> do
set topic [TopicsIsLocked =. val locked]
where_ (topic ^. TopicsId ==. val tid)
updateTopicIncrementReplyAndLasts ::
MonadIO m
=> Key Topics
-> Text
-> Key Posts
-> UTCTime
-> ReaderT SqlBackend m ()
updateTopicIncrementReplyAndLasts tid username pid now = do
update $ \topic -> do
set
topic
[ TopicsRepliesCount +=. (val 1)
, TopicsLastPoster =. (val $ Just username)
, TopicsLastPostId =. (val $ Just pid)
, TopicsLastPost =. (val $ Just now)
]
where_ (topic ^. TopicsId ==. val tid)
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Flux.Post where
import Import hiding (Value)
import Database.Esqueleto
import DBOp.CRUDPost
import DBOp.CRUDTopic
getPostsInTopic ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Posts
-> Int64
-> m [Entity Posts]
getPostsInTopic tid page
| page < 1 = invalidArgs ["Have you seen something page 0 before?"]
| otherwise = liftHandler $ runDB $ selectPostByTopicId tid page
......@@ -10,6 +10,7 @@ import Import hiding (Value)
import Database.Esqueleto
import DBOp.CRUDPost
import DBOp.CRUDTopic
import DBOp.CRUDForum
getTopicById ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
......@@ -25,3 +26,25 @@ getTopicById tid = do
case topics of
[x] -> return x
_ -> notFound
replyTopicByPosting ::
Key Users -> Text -> Key Topics -> Text -> Handler (Key Topics, Int64, Int)
replyTopicByPosting uid uname tid content = do
now <- liftIO getCurrentTime
topic <- getTopicById tid
if topicsIsLocked $ entityVal topic
then permissionDenied "Topic already locked"
else do
let fid = topicsForumId $ entityVal topic
num = topicsRepliesCount $ entityVal topic
page = floor $ (toRational num) / 25 + 1 :: Int64
pid <- liftHandler $ runDB $ insertPost tid (num + 1) uname uid content
liftHandler $
runDB $ do
updateForumIncrementReplyAndLasts
(topicsForumId $ entityVal topic)
uname
pid
now
updateTopicIncrementReplyAndLasts tid uname pid now
return (tid, page, num + 1)
......@@ -41,6 +41,8 @@ mkYesodData
/admin/forum AdmForumR GET POST
/forum/#Int64 ForumR GET POST
/forum/#Int64/#Int64 ForumPageR GET
/topic/#Int64 TopicR GET POST
/topic/#Int64/#Int64 TopicPageR GET
|]
type Form a = Html -> MForm (HandlerFor App) (FormResult a, Widget)
......
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Topic where
import Import
import Data.Time.LocalTime
import Database.Esqueleto
import Flux.Topic
import Flux.Post
import Flux.Forum
data PostForm = PostForm
{ postFormContent :: Textarea
} deriving (Show)
postForm :: Form PostForm
postForm =
renderDivs $ PostForm <$> areq textareaField "Reply Discussion" Nothing
getTopicR :: Int64 -> Handler Html
getTopicR tid = do
redirect $ TopicPageR tid 1
postTopicR :: Int64 -> Handler Html
postTopicR tid = do
(uid, name, group) <- allowedToPost
((res, wid), enct) <- runFormPost postForm
case res of
FormSuccess x -> do
let content = unTextarea . postFormContent $ x
(_, page, num) <- replyTopicByPosting uid name (toSqlKey tid) content
redirect $ TopicPageR tid page :#: ("post-" <> show num)
_ -> defaultLayout [whamlet|Please.|]
getTopicPageR :: Int64 -> Int64 -> Handler Html
getTopicPageR tid page = do
(uid, name, group) <- allowedToPost
posts <- getPostsInTopic (toSqlKey tid) page
topic <- getTopicById $ toSqlKey tid
forum <- getForumsInformation . topicsForumId . entityVal $ topic
(wid, enct) <- generateFormPost postForm
defaultLayout $(widgetFile "topic")
......@@ -20,7 +20,7 @@
<tr>
<td>
<strong>
<a [email protected]{HomeR}> #{s}
<a [email protected]{TopicR $ fromSqlKey key}> #{s}
<span>
<small> by #{p}
<td> #{rc}
......
<h4>
<a [email protected]{HomeR}> Index
<span> »
<a [email protected]{ForumR $ fromSqlKey $ entityKey forum}> #{forumsName $ entityVal forum}
<span> »
<a [email protected]{TopicR tid}> #{topicsSubject $ entityVal topic}
$forall (Entity pid (Posts tid n uname uid t content)) <- posts
<.row.row-no-padding>
<.column.column-100>
<span>#{show $ utcToLocalTime timeZone $ t}
<span .float-right #post-#{n}> #{n}
<.row.row-no-padding>
<.column.column-20>
<a [email protected]{HomeR}> #{uname}
<.column.column-80>
<.row>
<.column.column-100> #{content}
<form method=post [email protected]{TopicR tid} enctype=#{enct}>
^{wid}
<input .button name=reply value=reply type=submit>
\ No newline at end of file
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment