lock unlocked topic.

Cirkeltrek.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8544cbec364e66ad92188c1912b6afa41c8b90ea1da6ef8ef064e72ae96f5172
+-- hash: 8146799c97967808e50779a0ee879c0e0efa4025b3146f3a23d42319258bc009
 
 name:           Cirkeltrek
 version:        0.0.0
@@ -20,6 +20,7 @@ library
       Flux.AdmForum
       Flux.Forum
       Flux.Home
+      Flux.Topic
       Foundation
       Handler.Adm.Category
       Handler.Adm.Forum

src/DBOp/CRUDTopic.hs

@@ -8,7 +8,7 @@
 module DBOp.CRUDTopic where
 
 import           Import                        hiding (Value, groupBy, on,
-                                                (==.))
+                                                update, (=.), (==.))
 
 import           Database.Esqueleto
 import           Database.Esqueleto.PostgreSQL
@@ -31,3 +31,14 @@ insertTopic fid poster subject = do
       topicsLastPoster = Nothing
       topicsIsLocked = False
   insert Topics {..}
+
+selectTopicById tid = do
+  select $ from $ \topic -> do
+    where_ (topic ^. TopicsId ==. val tid)
+    limit 1
+    return topic
+
+updateTopicIsLocked tid locked = do
+  update $ \topic -> do
+    set topic [TopicsIsLocked =. val locked]
+    where_ (topic ^. TopicsId ==. val tid)

src/Flux/Forum.hs

@@ -10,8 +10,10 @@ import           Import             hiding (Value)
 import           Database.Esqueleto
 
 import           DBOp.CRUDForum
-import           DBOp.CRUDTopic
 import           DBOp.CRUDPost
+import           DBOp.CRUDTopic
+
+import           Flux.Topic
 
 getForumsInformation ::
      ( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
@@ -38,7 +40,7 @@ getTopicsInForum ::
   => Key Forums
   -> Int64
   -> m [Entity Topics]
-getTopicsInForum fid page | page < 0 = invalidArgs ["Yo! You can't look at negative value!"]
+getTopicsInForum fid page | page < 1 = invalidArgs ["Yo! Have you seen negative page before? Me neither."]
 getTopicsInForum fid page = liftHandler $ runDB $ selectTopicsByForumIdPage fid page
 
 createTopicByPosting ::
@@ -59,3 +61,23 @@ createTopicByPosting fid userid username subject content = do
   pid <- liftHandler $ runDB $ insertPost tid 1 username userid content
   return tid
 
+lockUnlockTopic ::
+     ( YesodPersistBackend (HandlerSite m) ~ SqlBackend
+     , PersistUniqueRead (YesodPersistBackend (HandlerSite m))
+     , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+     , PersistQueryRead (YesodPersistBackend (HandlerSite m))
+     , MonadHandler m
+     , YesodPersist (HandlerSite m)
+     )
+  => Bool
+  -> Grouping
+  -> Text
+  -> m ()
+lockUnlockTopic lock group tid
+  | group == Administrator || group == Moderator = do
+    topic <- getTopicById . toSqlKey . forceTextToInt64 $ tid
+    if (topicsIsLocked $ entityVal topic) == lock
+      then invalidArgs ["You can only switch the lock of the topic."]
+      else liftHandler $
+           runDB $ updateTopicIsLocked (toSqlKey . forceTextToInt64 $ tid) lock
+lockUnlockTopic _ lock _ = permissionDenied "You're not allowed to lock this topic."

src/Flux/Topic.hs

+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+module Flux.Topic where
+
+import           Import             hiding (Value)
+
+import           Database.Esqueleto
+import           DBOp.CRUDPost
+import           DBOp.CRUDTopic
+
+getTopicById ::
+     ( BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
+     , PersistQueryRead (YesodPersistBackend (HandlerSite m))
+     , PersistUniqueRead (YesodPersistBackend (HandlerSite m))
+     , YesodPersist (HandlerSite m)
+     , MonadHandler m
+     )
+  => Key Topics
+  -> m (Entity Topics)
+getTopicById tid = do
+  topics <- liftHandler $ runDB $ selectTopicById tid
+  case topics of
+    [x] -> return x
+    _   -> notFound

src/Handler/Forum.hs

 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Handler.Forum where
 
@@ -26,6 +27,7 @@ getForumR fid = redirect $ ForumPageR fid 1
 
 getForumPageR :: Int64 -> Int64 -> Handler Html
 getForumPageR fid page = do
+  (uid, name, group) <- allowedToPost
   forum <- getForumsInformation (toSqlKey fid)
   topics <- getTopicsInForum (toSqlKey fid ) page
   (wid, enct) <- generateFormPost createTopicForm
@@ -36,15 +38,28 @@ getForumPageR fid page = do
 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..."]
+  lock <- lookupPostParam "lock-topic"
+  unlock <- lookupPostParam "unlock-topic"
+  create <- lookupPostParam "create-topic"
+  topicids <- lookupPostParams "topic-id"
+  case (lock, unlock, create) of
+    (Just _, Nothing, Nothing) -> do
+      forM_ topicids $ lockUnlockTopic True group
+      redirect $ ForumR fid
+    (Nothing, Just _, Nothing) -> do
+      forM_ topicids $ lockUnlockTopic False group
+      redirect $ ForumR fid
+    (Nothing, Nothing, Just _) -> do
+      ((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..."]
+    _ -> invalidArgs ["Make up your mind!"]

templates/forum.hamlet

@@ -2,35 +2,63 @@
     <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
+<form [email protected]{ForumR fid} method=post> 
+  <table>
+    <thead>
       <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}
-
+        <th width="60%"> Subject
+        <th width="10%"> Replies Count
+        <th width="20%"> Last Active
+        $case group
+          $of Administrator
+            <th width="10%"> Lock. 
+          $of Moderator
+            <th width="10%"> Lock. 
+          $of _
+    <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
-        $nothing
-          <td> Empty
+          $case group
+            $of Administrator
+              <td width="5%"> <input name=topic-id value=#{fromSqlKey key} type=checkbox>
+              $if lock
+                <td width="5%"> Locked
+              $else
+                <td>
+            $of Moderator
+              <td width="5%"> <input name=topic-id value=#{fromSqlKey key} type=checkbox>
+              $if lock
+                <td width="5%"> Locked
+              $else
+                <td>
+            $of _
+  $case group
+    $of Administrator
+      <input .button name=lock-topic value=lock type=submit>
+      <input .button name=unlock-topic value=unlock type=submit>
+    $of Moderator
+      <input .button name=lock-topic value=lock type=submit>
+      <input .button name=unlock-topic value=unlock type=submit>
+    $of _
 <form method=post [email protected]{ForumR fid}>
  ^{wid}
-  <input .button-primary value=submit type=submit>
\ No newline at end of file
+  <input .button-primary name=create-topic value=submit type=submit>
\ No newline at end of file