shown forum.

Cirkeltrek.cabal

@@ -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

package.yaml

@@ -19,6 +19,7 @@ dependencies:
 - persistent-postgresql
 - shakespeare
 - template-haskell
+- time
 - yaml
 - yesod
 - yesod-auth

src/Application.hs

@@ -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
 

src/DBOp/CRUDForum.hs

@@ -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

src/DBOp/CRUDPost.hs

+{-# 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 {..}

src/DBOp/CRUDTopic.hs

+{-# 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 {..}

src/Flux/Forum.hs

+{-# 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
+

src/Foundation.hs

@@ -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)

src/Handler/Forum.hs

+{-# 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..."]

src/Import/Util.hs

@@ -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"

templates/forum.hamlet

+<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

templates/home.hamlet

@@ -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