Merge branch 'mitchellwrosen-master'

Handler/Discussion.hs

@@ -9,6 +9,6 @@ import Model.Discussion
 -- "root comment getter", by looking for a "state=open" or "state=closed" GET param.
 getDiscussion :: ((DiscussionId -> ExprCommentCond -> DB [Entity Comment]) -> Handler Html) -> Handler Html
 getDiscussion callback = lookupGetParam "state" >>= \case
-    Just "closed" -> callback fetchDiscussionClosedRootCommentsDB
+    Just "closed" -> callback fetchDiscussionClosedOrRetractedRootCommentsDB
     -- Not "closed"? Just accept anything else as meaning "open".
     _             -> callback fetchDiscussionRootCommentsDB

Handler/Wiki.hs

@@ -222,7 +222,7 @@ getWikiDiscussionR' project_handle target get_root_comments = do
           (wikiPageTarget page)
           root_comments
           def
-          (getMaxDepthDefault 0)
+          getMaxDepth
           False
           mempty
 
@@ -255,7 +255,7 @@ postNewWikiDiscussionR project_handle target = do
       Nothing
       user
       wikiPageDiscussion
-      (makeProjectCommentActionPermissionsMap (Just user) project_handle) >>= \case
+      (makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
         Left comment_id -> redirect (WikiCommentR project_handle target comment_id)
         Right (widget, form) -> defaultLayout $ previewWidget form "post" ($(widgetFile "wiki_discussion_wrapper"))
 

Import.hs

@@ -25,7 +25,6 @@ import           Data.Text                     as Import (Text)
 import qualified Data.Text                     as T
 import qualified Data.Text.Lazy                as TL
 import           Data.Time.Clock               as Import (UTCTime, diffUTCTime, getCurrentTime)
-import           Data.Time.Units
 import           Data.Typeable (Typeable)
 import           Database.Esqueleto            as Import hiding (on, valList)
 import qualified Database.Esqueleto
@@ -73,22 +72,30 @@ instance Count ShareCount where getCount (ShareCount c) = c
 newtype Color = Color Int deriving (Typeable, Num)
 
 -- from http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe
-readMaybe        :: (Read a) => String -> Maybe a
-readMaybe s      =  case [x | (x,t) <- reads s, ("","") <- lex t] of
-                         [x] -> Just x
-                         _   -> Nothing
-
-
-age :: UTCTime -> UTCTime -> String
-age a b = let s = round $ toRational $ diffUTCTime a b
-              f (t :: Second)
-                 | t > convertUnit (1 :: Fortnight) = show (convertUnit t :: Fortnight)
-                 | t > convertUnit (1 :: Week) = show (convertUnit t :: Week)
-                 | t > convertUnit (1 :: Day) = show (convertUnit t :: Day)
-                 | t > convertUnit (1 :: Hour) = show (convertUnit t :: Hour)
-                 | otherwise = show (convertUnit t :: Minute)
-           in f s
-
+readMaybe   :: (Read a) => String -> Maybe a
+readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+                  [x] -> Just x
+                  _   -> Nothing
+
+showDiffTime :: UTCTime -> UTCTime -> String
+showDiffTime x y =
+  let secs_ago = round (diffUTCTime x y)
+  in if | secs_ago < secsPerHour  -> go secs_ago secsPerMinute "m"
+        | secs_ago < secsPerDay   -> go secs_ago secsPerHour   "h"
+        | secs_ago < secsPerWeek  -> go secs_ago secsPerDay    "d"
+        | secs_ago < secsPerMonth -> go secs_ago secsPerWeek   "wk"
+        | secs_ago < secsPerYear  -> go secs_ago secsPerMonth  "mo"
+        | otherwise               -> go secs_ago secsPerYear   "yr"
+  where
+    go secs_ago divisor suffix = show (secs_ago `div` divisor) ++ suffix
+
+    secsPerMinute, secsPerHour, secsPerDay, secsPerWeek, secsPerMonth, secsPerYear :: Integer
+    secsPerMinute = 60
+    secsPerHour   = 3600     -- 60*60
+    secsPerDay    = 86400    -- 60*60*24
+    secsPerWeek   = 604800   -- 60*60*24*7
+    secsPerMonth  = 2592000  -- 60*60*24*30
+    secsPerYear   = 31536000 -- 60*60*24*365
 
 entitiesMap :: [Entity t] -> Map (Key t) t
 entitiesMap = foldr (\(Entity k v) -> M.insert k v) mempty

Model.hs

@@ -2,7 +2,7 @@
 
 module Model where
 
-import Model.Comment.Internal      (ClosureType, FlagReason, Visibility)
+import Model.Comment.Internal      (FlagReason, Visibility)
 import Model.Currency              (Milray)
 import Model.Established.Internal  (Established(..))
 import Model.Markdown.Diff         (MarkdownDiff)

Model/CollapseState.hs

@@ -7,12 +7,14 @@ import Model.CollapseState.Internal
 
 import Data.Time.Units
 
-collapseState :: UTCTime -> CommentClosure -> Handler CollapseState
-collapseState now closure =
-    return $ case (fromIntegral :: Integer -> Second) $ round $ diffUTCTime now $ commentClosureTs closure of
-        -- TODO: make these user preference
-        x | convertUnit x < (24 :: Hour) -> FullyVisible
-        x | convertUnit x < (72 :: Hour) -> Collapsed
-        _ -> FullyHidden
+collapseState :: Handler ()
+collapseState = undefined -- TODO(mitchell, david)
+-- collapseState :: UTCTime -> CommentClosure -> Handler CollapseState
+-- collapseState now closure =
+--     return $ case (fromIntegral :: Integer -> Second) $ round $ diffUTCTime now $ commentClosureTs closure of
+--         -- TODO: make these user preference
+--         x | convertUnit x < (24 :: Hour) -> FullyVisible
+--         x | convertUnit x < (72 :: Hour) -> Collapsed
+--         _ -> FullyHidden
 
 

Model/Comment/ActionPermissions.hs

@@ -8,6 +8,7 @@ module Model.Comment.ActionPermissions
 import Import
 
 import Model.Comment
+import Model.Comment.Mods
 import Model.User
 
 import qualified Data.Map      as M
@@ -19,6 +20,7 @@ type ActionPermissionsMap = Map CommentId CommentActionPermissions
 data CommentActionPermissions = CommentActionPermissions
     { can_add_tag   :: Bool
     , can_approve   :: Bool
+    , can_claim     :: Bool
     , can_close     :: Bool
     , can_delete    :: Bool
     , can_edit      :: Bool
@@ -27,10 +29,12 @@ data CommentActionPermissions = CommentActionPermissions
     , can_reply     :: Bool
     , can_rethread  :: Bool
     , can_retract   :: Bool
+    , can_unclaim   :: Bool
     }
 
 emptyCommentActionPermissions :: CommentActionPermissions
-emptyCommentActionPermissions = CommentActionPermissions False False False False False False False False False False
+emptyCommentActionPermissions =
+    CommentActionPermissions False False False False False False False False False False False False
 
 -- | Comment action permissions for a logged out user.
 loggedOutCommentActionPermissions :: CommentActionPermissions
@@ -41,22 +45,25 @@ makeLoggedOutCommentActionPermissionsMap = return .
     foldr (\(Entity comment_id _) -> M.insert comment_id loggedOutCommentActionPermissions) mempty
 
 -- | Action permissions that apply to both a Project discussion and a Projects WikiPage discussion.
-makeProjectCommentActionPermissionsMap :: Maybe (Entity User) -> Text -> MakeActionPermissionsMap
-makeProjectCommentActionPermissionsMap Nothing _ comments = makeLoggedOutCommentActionPermissionsMap comments
-makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_handle comments = do
+makeProjectCommentActionPermissionsMap :: Maybe (Entity User) -> Text -> CommentMods -> MakeActionPermissionsMap
+makeProjectCommentActionPermissionsMap Nothing _ _ comments = makeLoggedOutCommentActionPermissionsMap comments
+makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_handle CommentMods{..} comments = do
         let map2 :: (a -> b) -> (a -> c) -> [a] -> ([b],[c])
             map2 f g = foldr (\a (bs, cs) -> (f a : bs, g a : cs)) ([],[])
 
             (comment_ids, user_ids) = map2 entityKey (commentUser . entityVal) comments
 
-        (viewer_is_mod, user_map, closure_map, flag_map, comments_with_children) <- runYDB $ do
+        (viewer_is_mod, user_map, closing_map, retracting_map, ticket_map, claim_map, flag_map, comments_with_children) <- runYDB $ do
             Entity project_id _ <- getBy404 (UniqueProjectHandle project_handle)
 
-            (,,,,) <$> userIsProjectModeratorDB viewer_id project_id
-                   <*> (entitiesMap <$> fetchUsersInDB user_ids)
-                   <*> makeClosureMapDB comment_ids
-                   <*> makeFlagMapDB comment_ids
-                   <*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
+            (,,,,,,,) <$> userIsProjectModeratorDB viewer_id project_id
+                      <*> (mod_user_map . entitiesMap <$> fetchUsersInDB user_ids)
+                      <*> (mod_closure_map <$> makeCommentClosingMapDB comment_ids)
+                      <*> (mod_retract_map <$> makeCommentRetractingMapDB comment_ids)
+                      <*> (mod_ticket_map <$> makeTicketMapDB comment_ids)
+                      <*> (mod_claim_map <$> makeClaimedTicketMapDB comment_ids)
+                      <*> (mod_flag_map <$> makeFlagMapDB comment_ids)
+                      <*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
 
         let viewer_is_established = userIsEstablished viewer
             viewer_can_close = userCanCloseComment viewer
@@ -70,14 +77,18 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
                 in M.insert comment_id (CommentActionPermissions
                        { can_add_tag   = viewer_is_established
                        , can_approve   = viewer_is_mod && not (commentIsApproved comment)
-                       , can_close     = viewer_can_close && M.notMember comment_id closure_map
+                       , can_claim     = M.member comment_id ticket_map && M.notMember comment_id claim_map
+                       , can_close     = viewer_can_close && M.notMember comment_id closing_map && commentIsApproved comment
                        , can_delete    = viewer_id == user_id && S.notMember comment_id comments_with_children
                        , can_edit      = userCanEditComment viewer_id comment
                        , can_establish = viewer_is_mod && userIsUnestablished user
                        , can_flag      = viewer_is_established && viewer_id /= user_id && M.notMember comment_id flag_map
-                       , can_reply     = True
+                       , can_reply     = commentIsApproved comment
                        , can_rethread  = viewer_is_mod || viewer_id == user_id
-                       , can_retract   = viewer_id == user_id
+                       , can_retract   = viewer_id == user_id && M.notMember comment_id retracting_map && commentIsApproved comment
+                       , can_unclaim   = maybe False
+                                               (\t -> ticketClaimingUser t == viewer_id)
+                                               (M.lookup comment_id claim_map)
                        })
 
         return (foldr step mempty comments)

Model/Comment/HandlerInfo.hs

@@ -7,6 +7,7 @@ module Model.Comment.HandlerInfo
 import Import
 
 import Model.Comment.ActionPermissions
+import Model.Comment.Mods
 import Model.Comment.Routes
 import Model.Comment.Sql
 
@@ -20,16 +21,16 @@ data CommentHandlerInfo = CommentHandlerInfo
     , commentHandlerMakeActionPermissionsMap :: MakeActionPermissionsMap
     }
 
-projectCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> CommentHandlerInfo
-projectCommentHandlerInfo muser project_id project_handle =
+projectCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> CommentMods -> CommentHandlerInfo
+projectCommentHandlerInfo muser project_id project_handle mods =
     CommentHandlerInfo
         (exprCommentProjectPermissionFilter (entityKey <$> muser) (val project_id))
         (projectCommentRoutes project_handle)
-        (makeProjectCommentActionPermissionsMap muser project_handle)
+        (makeProjectCommentActionPermissionsMap muser project_handle mods)
 
-wikiPageCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> Text -> CommentHandlerInfo
-wikiPageCommentHandlerInfo muser project_id project_handle target =
+wikiPageCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> Text -> CommentMods -> CommentHandlerInfo
+wikiPageCommentHandlerInfo muser project_id project_handle target mods =
     CommentHandlerInfo
         (exprCommentProjectPermissionFilter (entityKey <$> muser) (val project_id))
         (wikiPageCommentRoutes project_handle target)
-        (makeProjectCommentActionPermissionsMap muser project_handle)
+        (makeProjectCommentActionPermissionsMap muser project_handle mods)

Model/Comment/Internal.hs

@@ -7,12 +7,6 @@ import Data.Text           (Text)
 
 import Yesod.Markdown      (Markdown)
 
-data ClosureType
-    = Retracted
-    | Closed
-    deriving (Read, Show)
-derivePersistField "ClosureType"
-
 -- VisPublic = visible to all | VisPrivate = visible to topic-poster and
 -- those with provenance over the discussion (e.g. project team for project
 -- discussion ) | VisInternal = visible only to those with provenance over

Model/Comment/Mods.hs

+module Model.Comment.Mods where
+
+import Import
+
+import Data.Default (Default, def)
+
+-- | Data type used in makeCommentWidgetMod, containing modifications to comment-action-related
+-- data structures.
+data CommentMods = CommentMods
+    { mod_earlier_closures :: [CommentClosing]                              -> [CommentClosing]
+    , mod_earlier_retracts :: [CommentRetracting]                           -> [CommentRetracting]
+    , mod_user_map         :: Map UserId User                               -> Map UserId User
+    , mod_closure_map      :: Map CommentId CommentClosing                  -> Map CommentId CommentClosing
+    , mod_retract_map      :: Map CommentId CommentRetracting               -> Map CommentId CommentRetracting
+    , mod_ticket_map       :: Map CommentId (Entity Ticket)                 -> Map CommentId (Entity Ticket)
+    , mod_claim_map        :: Map CommentId TicketClaiming                  -> Map CommentId TicketClaiming
+    , mod_flag_map         :: Map CommentId (CommentFlagging, [FlagReason]) -> Map CommentId (CommentFlagging, [FlagReason])
+    , mod_tag_map          :: Map TagId Tag                                 -> Map TagId Tag
+    }
+
+instance Default CommentMods where
+    def = CommentMods id id id id id id id id id
+

Model/Comment/Routes.hs

@@ -9,6 +9,7 @@ data CommentRoutes = CommentRoutes
     { comment_route_add_tag   :: CommentId -> Route App
     , comment_route_approve   :: CommentId -> Route App
     , comment_route_close     :: CommentId -> Route App
+    , comment_route_claim     :: CommentId -> Route App
     , comment_route_delete    :: CommentId -> Route App
     , comment_route_edit      :: CommentId -> Route App
     , comment_route_flag      :: CommentId -> Route App
@@ -17,26 +18,20 @@ data CommentRoutes = CommentRoutes
     , comment_route_rethread  :: CommentId -> Route App
     , comment_route_retract   :: CommentId -> Route App
     , comment_route_tag       :: CommentId -> TagId -> Route App
+    , comment_route_unclaim   :: CommentId -> Route App
     }
 
 dummyCommentRoutes :: CommentRoutes
-dummyCommentRoutes = CommentRoutes
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (const HomeR)
-    (\_ _ -> HomeR)
+dummyCommentRoutes =
+    CommentRoutes (const HomeR) (const HomeR) (const HomeR) (const HomeR) (const HomeR) (const HomeR)
+                  (const HomeR) (const HomeR) (const HomeR) (const HomeR) (const HomeR) (\_ _ -> HomeR)
+                  (const HomeR)
 
 projectCommentRoutes :: Text -> CommentRoutes
 projectCommentRoutes project_handle = CommentRoutes
     { comment_route_add_tag   = ProjectCommentAddTagR   project_handle
     , comment_route_approve   = ApproveProjectCommentR  project_handle
+    , comment_route_claim     = ClaimProjectCommentR    project_handle
     , comment_route_close     = CloseProjectCommentR    project_handle
     , comment_route_delete    = DeleteProjectCommentR   project_handle
     , comment_route_edit      = EditProjectCommentR     project_handle
@@ -46,12 +41,14 @@ projectCommentRoutes project_handle = CommentRoutes
     , comment_route_rethread  = RethreadProjectCommentR project_handle
     , comment_route_retract   = RetractProjectCommentR  project_handle
     , comment_route_tag       = ProjectCommentTagR      project_handle
+    , comment_route_unclaim   = UnclaimProjectCommentR  project_handle
     }
 
 wikiPageCommentRoutes :: Text -> Text -> CommentRoutes
 wikiPageCommentRoutes project_handle target = CommentRoutes
     { comment_route_add_tag   = WikiCommentAddTagR   project_handle target
     , comment_route_approve   = ApproveWikiCommentR  project_handle target
+    , comment_route_claim     = ClaimWikiCommentR    project_handle target
     , comment_route_close     = CloseWikiCommentR    project_handle target
     , comment_route_delete    = DeleteWikiCommentR   project_handle target
     , comment_route_edit      = EditWikiCommentR     project_handle target
@@ -61,4 +58,5 @@ wikiPageCommentRoutes project_handle target = CommentRoutes
     , comment_route_rethread  = RethreadWikiCommentR project_handle target
     , comment_route_retract   = RetractWikiCommentR  project_handle target
     , comment_route_tag       = WikiCommentTagR      project_handle target
+    , comment_route_unclaim   = UnclaimWikiCommentR  project_handle target
     }

Model/Comment/Sql.hs

-module Model.Comment.Sql where
+module Model.Comment.Sql
+    ( ExprCommentCond
+    , exprCommentApproved
+    , exprCommentClosedOrRetracted
+    , exprCommentFlagged
+    , exprCommentIsRoot
+    , exprCommentNotRethreaded
+    , exprCommentOnDiscussion
+    , exprCommentOpen
+    , exprCommentPostedBy
+    , exprCommentProjectPermissionFilter
+    , exprCommentProjectPermissionFilterIncludingRethreaded
+    , exprCommentRootPostedBy
+    , exprCommentUnapproved
+    , exprCommentViewedBy
+    , querCommentAncestors
+    , querCommentDescendants
+    , querCommentsDescendants
+    ) where
 
 import Import
 
 import Model.User.Sql
 
+-- | A SQL expression for a comment "condition" (Comment -> Bool).
 type ExprCommentCond = SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
 
-exprCommentClosed, exprCommentOpen :: ExprCommentCond
-exprCommentClosed c = c ^. CommentId `in_`   exprClosedCommentIds
-exprCommentOpen   c = c ^. CommentId `notIn` exprClosedCommentIds
+exprCommentClosedOrRetracted, exprCommentOpen :: ExprCommentCond
+exprCommentClosedOrRetracted c = c ^. CommentId `in_`   exprClosedCommentIds ||. c ^. CommentId `in_`   exprRetractedCommentIds
+exprCommentOpen              c = c ^. CommentId `notIn` exprClosedCommentIds &&. c ^. CommentId `notIn` exprRetractedCommentIds
 
 exprClosedCommentIds :: SqlExpr (ValueList CommentId)
 exprClosedCommentIds =
     subList_select $
-    from $ \cl ->
-    return (cl ^. CommentClosureComment)
+    from $ \cc ->
+    return (cc ^. CommentClosingComment)
+
+exprRetractedCommentIds :: SqlExpr (ValueList CommentId)
+exprRetractedCommentIds =
+    subList_select $
+    from $ \cr ->
+    return (cr ^. CommentRetractingComment)
 
 -- | Comment is root?
 exprCommentIsRoot :: ExprCommentCond

Model/Discussion.hs

 module Model.Discussion
     ( DiscussionOn(..)
     , createDiscussionDB
-    , fetchDiscussionClosedRootCommentsDB
+    , fetchDiscussionClosedOrRetractedRootCommentsDB
     , fetchDiscussionDB
     , fetchDiscussionsDB
     , fetchDiscussionRootCommentsDB
@@ -93,8 +93,8 @@ fetchDiscussionRootCommentsDB :: DiscussionId -> ExprCommentCond -> DB [Entity C
 fetchDiscussionRootCommentsDB = fetchRootComments exprCommentOpen
 
 -- | Get all closed root Comments on a Discussion.
-fetchDiscussionClosedRootCommentsDB :: DiscussionId -> ExprCommentCond -> DB [Entity Comment]
-fetchDiscussionClosedRootCommentsDB = fetchRootComments exprCommentClosed
+fetchDiscussionClosedOrRetractedRootCommentsDB :: DiscussionId -> ExprCommentCond -> DB [Entity Comment]
+fetchDiscussionClosedOrRetractedRootCommentsDB = fetchRootComments exprCommentClosedOrRetracted
 
 fetchRootComments :: ExprCommentCond -> DiscussionId -> ExprCommentCond -> DB [Entity Comment]
 fetchRootComments open_or_closed discussion_id has_permission =

Model/Project.hs

@@ -393,5 +393,5 @@ fetchProjectOpenTicketsDB project_id muser_id = do
         on_ (t ^. TicketComment ==. c ^. CommentId)
         where_ $
             c ^. CommentDiscussion `in_` valList discussion_ids &&.
-            c ^. CommentId `notIn` exprClosedCommentIds
+            exprCommentOpen c
         return t

Model/Tag.hs

 module Model.Tag
-    ( TagMap
-    , AnnotatedTag(..)
+    ( AnnotatedTag(..)
     , annotTagName
     , annotTagScore
     , annotTagScoreString
@@ -21,8 +20,6 @@ import qualified Data.Map    as M
 import qualified Data.List   as L
 import           Text.Printf
 
-type TagMap = Map TagId Tag
-
 fetchAllTagsDB :: DB [Entity Tag]
 fetchAllTagsDB = select (from return)
 

Model/User.hs

@@ -28,6 +28,7 @@ module Model.User
     , fetchUsersInDB
     , updateUserDB
     , userCanDeleteCommentDB
+    , userClaimCommentDB
     , userHasRoleDB
     , userHasRolesAnyDB
     , userIsAffiliatedWithProjectDB
@@ -38,6 +39,7 @@ module Model.User
     , userMaybeViewProjectCommentsDB
     , userReadNotificationsDB
     , userReadVolunteerApplicationsDB
+    , userUnclaimCommentDB
     , userUnwatchProjectDB
     , userViewCommentsDB
     , userViewWikiEditsDB
@@ -388,6 +390,15 @@ userCanDeleteCommentDB user_id (Entity comment_id comment) =
               then return True
               else return False
 
+-- TODO: claim event
+userClaimCommentDB :: UserId -> CommentId -> Maybe Text -> DB ()
+userClaimCommentDB user_id comment_id mnote = liftIO getCurrentTime >>= \now ->
+    insert_ (TicketClaiming now user_id comment_id mnote)
+
+-- TODO: unclaim event
+userUnclaimCommentDB :: UserId -> CommentId -> Maybe Text -> DB ()
+userUnclaimCommentDB _ comment_id _ = deleteBy (UniqueTicketClaiming comment_id)
+
 -- | Fetch a User's number of unviewed comments on each WikiPage of a Project.
 fetchNumUnviewedCommentsOnProjectWikiPagesDB :: UserId -> ProjectId -> DB (Map WikiPageId Int)
 fetchNumUnviewedCommentsOnProjectWikiPagesDB user_id project_id = fmap (M.fromList . map unwrapValues) $

Snowdrift.cabal

@@ -33,6 +33,7 @@ library
                      Model.Comment
                      Model.Comment.ActionPermissions
                      Model.Comment.HandlerInfo
+                     Model.Comment.Mods
                      Model.Comment.Routes
                      Model.Comment.Sql
                      Model.Currency
@@ -124,6 +125,7 @@ library
                 GeneralizedNewtypeDeriving
                 LambdaCase
                 MultiParamTypeClasses
+                MultiWayIf
                 NoImplicitPrelude
                 NoMonomorphismRestriction
                 QuasiQuotes

View/Discussion.hs

-module View.Discussion where
-
-import Model.Comment.Internal
-
-discussionCommentTree :: CommentMods              -- ^ Comment structure modifications.
-                      -> CommentActionPermissions
-                      -> MaxDepth
-                      -> Bool           -- ^ Is preview?
-                      -> Widget         -- ^ Widget to display under root comment.
-                      -> CommentId      -- ^ Root comment id.
-                      -> Handler (Widget, Tree (Entity Comment))

View/SnowdriftEvent.hs

@@ -21,11 +21,14 @@ renderCommentPostedEvent
         -> Text
         -> Map DiscussionId DiscussionOn
         -> ActionPermissionsMap
-        -> Map CommentId [CommentClosure]
-        -> UserMap
-        -> ClosureMap
-        -> TicketMap
-        -> FlagMap
+        -> Map CommentId [CommentClosing]
+        -> Map CommentId [CommentRetracting]
+        -> Map UserId User
+        -> Map CommentId CommentClosing
+        -> Map CommentId CommentRetracting
+        -> Map CommentId (Entity Ticket)
+        -> Map CommentId TicketClaiming
+        -> Map CommentId (CommentFlagging, [FlagReason])
         -> Widget
 renderCommentPostedEvent
         comment_id
@@ -35,9 +38,12 @@ renderCommentPostedEvent
         discussion_map
         action_permissions_map
         earlier_closures_map
+        earlier_retracts_map
         user_map
         closure_map
+        retract_map
         ticket_map
+        claim_map
         flag_map = do
 
     let action_permissions = lookupErr "renderCommentPostedEvent: comment id missing from permissions map"
@@ -57,7 +63,7 @@ renderCommentPostedEvent
                 (projectCommentRoutes projectHandle, [whamlet|
                     <div .event>
                         On
-                        <a href=@{ProjectR projectHandle}>#{projectName}#
+                        <a href=@{ProjectDiscussionR projectHandle}>#{projectName}#
                         :
 
                         ^{comment_widget}
@@ -67,7 +73,7 @@ renderCommentPostedEvent
                 (wikiPageCommentRoutes project_handle wikiPageTarget, [whamlet|
                     <div .event>
                         On the
-                        <a href=@{WikiR project_handle wikiPageTarget}>#{wikiPageTarget}
+                        <a href=@{WikiDiscussionR project_handle wikiPageTarget}>#{wikiPageTarget}
                         wiki page:
 
                         ^{comment_widget}
@@ -80,9 +86,12 @@ renderCommentPostedEvent
               routes
               action_permissions
               (M.findWithDefault [] comment_id earlier_closures_map)
+              (M.findWithDefault [] comment_id earlier_retracts_map)
               user
               (M.lookup comment_id closure_map)
+              (M.lookup comment_id retract_map)
               (M.lookup comment_id ticket_map)
+              (M.lookup comment_id claim_map)
               (M.lookup comment_id flag_map)
               False
               mempty

Widgets/Preview.hs

@@ -11,15 +11,8 @@ previewWidget form action widget =
 
         ^{widget}
 
-        <div .alert .alert-danger>
-            This is a preview; your changes have <em>not</em> been saved!
-
         <form #edit-preview method="POST">
-            <button type="submit" name="mode" value="preview">preview
-            <button .preview-action-button type="submit" name="mode" value="post">#{action}
-
             ^{form}
-
             <button type="submit" name="mode" value="preview">preview
             <button .preview-action-button type="submit" name="mode" value="post">#{action}
     |]

Widgets/Time.hs

@@ -18,6 +18,6 @@ renderTime time = do
 
     toWidget [hamlet|
         <span title="#{render time}">
-            #{age now time}&nbsp;ago
+            #{showDiffTime now time}&nbsp;ago
     |]
 

comment.cassius

-.comment
-    padding : 0 .8em 0.3em 1em
-    margin-top : 1.8em
-    border-bottom-left-radius: 1em
-    font-size : 15px
-
-.comment p, .comment ul, .comment ol, .comment h1, .comment h2, .comment h3, .comment h4, .comment h5, .comment h6
-    margin : .5em 0
-
-.comment figure
-    text-align : left
-
-.comment h1
-    font-size : large
-
-.comment h2
-    font-size : medium
-
-.comment blockquote
-    font-size : 14px
-    margin : 1em
-
-.ticket-title
-    background-color: lightblue;
-        border-radius: 1em;
-            padding: 0.5em;
-
-.comment-head, .comment-action
-    margin-right : 1em
-    margin-bottom : 0.5em
-    display : inline-block
-    padding : 2px 5px
-
-.top_level
-    border-left : solid black 0.2em
-
-.even_depth
-    border-left : solid lightblue 0.2em
-
-.odd_depth
-    border-left : solid lightgrey 0.2em
-
-.small_avatar
-    width : 2.5em
-    height : 2.5em
-    padding : 0em
-    margin-right : 0.3em
-    border-radius : 5px
-
-.closed
-    color : goldenrod
-    border-left : solid goldenrod 0.25em
-    padding-left : 0.5em
-
-.retracted
-    color : darkred
-    border-left : solid darkred 0.25em
-    padding-left : 0.5em
-