Commit e45b6107 authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

shown forum.

parent 8faeb845
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 3fbfd29efd03fac59b725b0b8693799e72aa4ffe7f2fb1b9d0b9fed69543d1cc
-- hash: 8544cbec364e66ad92188c1912b6afa41c8b90ea1da6ef8ef064e72ae96f5172
name: Cirkeltrek
version: 0.0.0
......@@ -14,12 +14,16 @@ library
Application
DBOp.CRUDCategory
DBOp.CRUDForum
DBOp.CRUDPost
DBOp.CRUDTopic
Flux.AdmCategory
Flux.AdmForum
Flux.Forum
Flux.Home
Foundation
Handler.Adm.Category
Handler.Adm.Forum
Handler.Forum
Handler.Home
Handler.Profile
Import
......@@ -51,6 +55,7 @@ library
, persistent-template
, shakespeare
, template-haskell
, time
, wai
, wai-extra
, wai-logger
......@@ -90,6 +95,7 @@ executable Cirkeltrek
, persistent-template
, shakespeare
, template-haskell
, time
, wai
, wai-extra
, wai-logger
......@@ -129,6 +135,7 @@ executable Seed
, persistent-template
, shakespeare
, template-haskell
, time
, wai
, wai-extra
, wai-logger
......
......@@ -19,6 +19,7 @@ dependencies:
- persistent-postgresql
- shakespeare
- template-haskell
- time
- yaml
- yesod
- yesod-auth
......
......@@ -4,6 +4,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application where
......@@ -28,6 +29,7 @@ import Handler.Home
import Handler.Profile
import Handler.Adm.Category
import Handler.Adm.Forum
import Handler.Forum
mkYesodDispatch "App" resourcesApp
......
......@@ -56,3 +56,33 @@ deleteForumById fid = do
return forum
forM_ forums (deleteCascade . entityKey)
selectTopicsByForumIdPage ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Key Forums
-> Int64
-> ReaderT backend m [Entity Topics]
selectTopicsByForumIdPage fid page = do
select $
from $ \topic -> do
where_ (topic ^. TopicsForumId ==. val fid)
offset ((page - 1) * 25)
limit 25
return topic
selectForumById ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> (Key Forums)
-> ReaderT backend m [Entity Forums]
selectForumById fid = do
select $ from $ \forum -> do
where_ (forum ^. ForumsId ==. val fid)
limit 1
return forum
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module DBOp.CRUDPost where
import Import hiding (Value, groupBy, on,
(==.))
import Database.Esqueleto
import Database.Esqueleto.PostgreSQL
insertPost ::
(BaseBackend backend ~ SqlBackend, MonadIO m, PersistStoreWrite backend)
=> Key Topics
-> Int
-> Text
-> Key Users
-> Text
-> ReaderT backend m (Key Posts)
insertPost tid number username userid content = do
now <- liftIO getCurrentTime
let postsTopicId = tid
postsNumber = number
postsUsername = username
postsUserId = userid
postsTime = now
postsContent = content
insert Posts {..}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module DBOp.CRUDTopic where
import Import hiding (Value, groupBy, on,
(==.))
import Database.Esqueleto
import Database.Esqueleto.PostgreSQL
insertTopic ::
(BaseBackend backend ~ SqlBackend, MonadIO m, PersistStoreWrite backend)
=> Key Forums
-> Text
-> Text
-> ReaderT backend m (Key Topics)
insertTopic fid poster subject = do
now <- liftIO getCurrentTime
let topicsForumId = fid
topicsPoster = poster
topicsSubject = subject
topicsRepliesCount = 0
topicsStartTime = now
topicsLastPost = Nothing
topicsLastPostId = Nothing
topicsLastPoster = Nothing
topicsIsLocked = False
insert Topics {..}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Flux.Forum where
import Import hiding (Value)
import Database.Esqueleto
import DBOp.CRUDForum
import DBOp.CRUDTopic
import DBOp.CRUDPost
getForumsInformation ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Forums
-> m (Entity Forums)
getForumsInformation fid = do
forum <- liftHandler $ runDB $ selectForumById fid
case forum of
[x] -> return x
_ -> notFound
getTopicsInForum ::
( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistQueryRead (YesodPersistBackend (HandlerSite m))
, PersistUniqueRead (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Forums
-> Int64
-> m [Entity Topics]
getTopicsInForum fid page | page < 0 = invalidArgs ["Yo! You can't look at negative value!"]
getTopicsInForum fid page = liftHandler $ runDB $ selectTopicsByForumIdPage fid page
createTopicByPosting ::
( BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, PersistStoreWrite (YesodPersistBackend (HandlerSite m))
, YesodPersist (HandlerSite m)
, MonadHandler m
)
=> Key Forums
-> Key Users
-> Text
-> Text
-> Text
-> m (Key Topics)
createTopicByPosting fid userid username subject content = do
now <- liftIO getCurrentTime
tid <- liftHandler $ runDB $ insertTopic fid username subject
pid <- liftHandler $ runDB $ insertPost tid 1 username userid content
return tid
......@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Foundation where
......@@ -32,12 +33,14 @@ data App = App
mkYesodData
"App"
[parseRoutes|
/ HomeR GET
/static StaticR Static appStatic
/auth SigninR Auth getAuth
/profile ProfileR GET
/admin/category AdmCategoryR GET POST
/admin/forum AdmForumR GET POST
/ HomeR GET
/static StaticR Static appStatic
/auth SigninR Auth getAuth
/profile ProfileR GET
/admin/category AdmCategoryR GET POST
/admin/forum AdmForumR GET POST
/forum/#Int64 ForumR GET POST
/forum/#Int64/#Int64 ForumPageR GET
|]
type Form a = Html -> MForm (HandlerFor App) (FormResult a, Widget)
......@@ -78,7 +81,7 @@ instance Yesod App where
isAuthorized (SigninR _) _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
isAuthorized _ _ = isLoggedIn
isAuthorized _ _ = isLoggedIn
isLoggedIn :: Handler AuthResult
isLoggedIn = do
......@@ -138,3 +141,10 @@ allowedToAdmin = do
Nothing -> permissionDenied "You're not allowed to see this page."
(Just (uid, name, Administrator)) -> return (uid, name, Administrator)
(Just (uid, name, _)) -> permissionDenied "You're not the admin of this site."
allowedToPost = do
midnamegroup <- getUserAndGrouping
case midnamegroup of
Nothing -> permissionDenied "You're not allowed to see this page."
(Just (uid, name, Banned)) -> permissionDenied "You're banned."
(Just (uid, name, _)) -> return (uid, name, Administrator)
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Handler.Forum where
import Import
import Data.Time.LocalTime
import Database.Esqueleto
import Flux.Forum
data CreateTopicForm = CreateTopicForm
{ createTopicFormSubject :: Text
, createTopicFormContent :: Textarea
}
createTopicForm :: Form CreateTopicForm
createTopicForm =
renderDivs $
CreateTopicForm <$> areq textField "New Subject" Nothing <*>
areq textareaField "Opening Post" Nothing
getForumR :: Int64 -> Handler Html
getForumR fid = redirect $ ForumPageR fid 1
getForumPageR :: Int64 -> Int64 -> Handler Html
getForumPageR fid page = do
forum <- getForumsInformation (toSqlKey fid)
topics <- getTopicsInForum (toSqlKey fid ) page
(wid, enct) <- generateFormPost createTopicForm
defaultLayout $ do
setTitle "Index"
$(widgetFile "forum")
postForumR :: Int64 -> Handler Html
postForumR fid = do
(uid, name, group) <- allowedToPost
((res, wid), enct) <- runFormPost createTopicForm
case res of
FormSuccess r -> do
tid <-
createTopicByPosting
(toSqlKey fid)
uid
name
(createTopicFormSubject r)
(unTextarea $ createTopicFormContent r)
redirect $ ForumR fid -- we will back to it later.
_ -> invalidArgs ["Come on..."]
......@@ -2,10 +2,13 @@
module Import.Util
( forceTextToInt64
, zip8
, timeZone
) where
import ClassyPrelude.Yesod
import Data.Time.LocalTime
forceTextToInt64 :: Text -> Int64
forceTextToInt64 t =
case readMay t of
......@@ -38,3 +41,6 @@ zipWith8 ::
zipWith8 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) (h:hs) =
z a b c d e f g h : zipWith8 z as bs cs ds es fs gs hs
zipWith8 z _ _ _ _ _ _ _ _ = []
timeZone :: TimeZone
timeZone = TimeZone 420 False "Jakarta"
<h4>
<a [email protected]{HomeR}> Index
<span> »
<a [email protected]{ForumR fid}> #{forumsName $ entityVal forum}
<table>
<thead>
<tr>
<th width="60%"> Subject
<th width="20%"> Replies Count
<th width="30%"> Last Active
<tbody>
$forall (Entity key (Topics fid p s rc st lp lpid lposter lock)) <- topics
<tr>
<td>
<strong>
<a [email protected]{HomeR}> #{s}
<span>
<small> by #{p}
<td> #{rc}
$maybe lastpost <- lp
$maybe lastpostid <- lpid
$maybe lastposter <- lposter
<td>
<a [email protected]{HomeR}#post-#{rc}>
#{show $ utcToLocalTime timeZone lastpost}
<small> by #{lastposter}
$nothing
<td> Empty
$nothing
<td> Empty
$nothing
<td> Empty
<form method=post [email protected]{ForumR fid}>
^{wid}
<input .button-primary value=submit type=submit>
\ No newline at end of file
......@@ -14,7 +14,7 @@ $forall (category, forums) <- categoriesforindex
<tr>
<td>
<strong>
<a href=#{fromSqlKey kf}> #{fname}
<a href=@{ForumR $ fromSqlKey kf}> #{fname}
<span>
<small>
$maybe desc <- fdesc
......
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