UI: Serve HTML in getClothR, copied from getTicketR

src/Vervis/Handler/Cloth.hs

@@ -26,6 +26,10 @@ module Vervis.Handler.Cloth
 
     , getClothDepR
 
+    , postClothFollowR
+    , postClothUnfollowR
+    , postClothReplyR
+
 
 
 
@@ -60,11 +64,14 @@ where
 import Control.Monad
 import Data.Bifunctor
 import Data.Bitraversable
+import Data.Bool
 import Data.Function
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Text (Text)
 import Data.Traversable
 import Database.Persist
+import Text.Blaze.Html (Html, preEscapedToHtml)
+import Yesod.Auth
 import Yesod.Core
 import Yesod.Persist.Core
 
@@ -98,8 +105,13 @@ import Vervis.Model.Ticket
 import Vervis.Paginate
 import Vervis.Persist.Actor
 import Vervis.Recipient
+import Vervis.Settings
+import Vervis.Style
 import Vervis.Ticket
+import Vervis.Time (showDate)
 import Vervis.Web.Actor
+import Vervis.Widget.Discussion
+import Vervis.Widget.Person
 
 getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
 getClothR loomHash clothHash = do
@@ -205,47 +217,51 @@ getClothR loomHash clothHash = do
             , AP.ticketAttachment = Just (hLocal, mergeRequestAP)
             }
 
-    provideHtmlAndAP' authorHost ticketAP $ redirectToPrettyJSON here
+    provideHtmlAndAP' authorHost ticketAP getClothHtml
     where
-    here = ClothR loomHash clothHash
+    getClothHtml = do
-
+        mpid <- maybeAuthId
-    {-
+        (ticket, author, tparams, eparams, cparams) <- handlerToWidget $ runDB $ do
-    mpid <- maybeAuthId
+            (_loom, _ticketloom, Entity ticketID ticket, author, _maybe_ResolveAndEitherTrlOrTrr, _bundles) <-
-    ( wshr, wfl,
+                getCloth404 loomHash clothHash
-      author, massignee, mresolved, cloth, lcloth, tparams, eparams, cparams) <-
+            (ticket,,,,)
-        runDB $ do
+                <$> bitraverse
-            (Entity sid sharer, Entity jid project, Entity tid cloth, Entity _ lcloth, _etcl, _etpl, author, resolved) <- getProjectCloth404 shar proj ltkhid
+                        (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
-            tparams <- getClothTextParams tid wid
+                            p <- getJust personID
-            eparams <- getClothEnumParams tid wid
+                            (Entity personID p,) <$> getJust (personActor p)
-            cparams <- getClothClasses tid wid
+                        )
-            return
+                        (\ (Entity _ (TicketAuthorRemote _ remoteActorID _)) -> do
-                ( wshr, wfl
+                            ra <- getJust remoteActorID
-                , author', massignee, mresolved, cloth, lcloth
+                            ro <- getJust $ remoteActorIdent ra
-                , tparams, eparams, cparams
+                            i <- getJust $ remoteObjectInstance ro
-                )
+                            return (i, ro, ra)
-    let desc :: Widget
+                        )
-        desc = toWidget $ preEscapedToMarkup $ clothDescription cloth
+                        author
-        discuss =
+                <*> getTicketTextParams ticketID --wid
-            discussionW
+                <*> getTicketEnumParams ticketID --wid
-                (return $ localClothDiscuss lcloth)
+                <*> getTicketClasses ticketID --wid
-                (ProjectClothTopReplyR shar proj ltkhid)
+        hashMessageKey <- handlerToWidget getEncodeKeyHashid
-                (ProjectClothReplyR shar proj ltkhid . encodeHid)
+        let desc :: Widget
-    cRelevant <- newIdent
+            desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
-    cIrrelevant <- newIdent
+            discuss =
-    let relevant filt =
+                discussionW
-            bool cIrrelevant cRelevant $
+                    (return $ ticketDiscuss ticket)
-            case clothStatus cloth of
+                    (ClothReplyR loomHash clothHash)
-                TSNew    -> wffNew filt
+                    (ReplyR . hashMessageKey)
-                TSTodo   -> wffTodo filt
+        cRelevant <- newIdent
-                TSClosed -> wffClosed filt
+        cIrrelevant <- newIdent
-    provideHtmlAndAP' host clothAP $
+        let relevant filt =
+                bool cIrrelevant cRelevant $
+                case ticketStatus ticket of
+                    TSNew    -> wffNew filt
+                    TSTodo   -> wffTodo filt
+                    TSClosed -> wffClosed filt
         let followButton =
                 followW
-                    (ProjectClothFollowR shar proj ltkhid)
+                    (ClothFollowR loomHash clothHash)
-                    (ProjectClothUnfollowR shar proj ltkhid)
+                    (ClothUnfollowR loomHash clothHash)
-                    (return $ localClothFollowers lcloth)
+                    (ticketFollowers ticket)
-        in  $(widgetFile "cloth/one")
+        $(widgetFile "cloth/one")
-    -}
 
 getClothDiscussionR
     :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
@@ -481,6 +497,29 @@ getClothDepR _ _ _ = do
             tdc
     -}
 
+postClothFollowR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
+postClothFollowR _ = error "Temporarily disabled"
+
+postClothUnfollowR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
+postClothUnfollowR _ = error "Temporarily disabled"
+
+postClothReplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler Html
+postClothReplyR _ _ = error "Temporarily disabled"
+    {-
+    hLocal <- getsYesod $ appInstanceHost . appSettings
+    postTopReply
+        hLocal
+        [ProjectR shr prj]
+        [ ProjectFollowersR shr prj
+        , ProjectTicketParticipantsR shr prj ltkhid
+        , ProjectTicketTeamR shr prj ltkhid
+        ]
+        (ProjectTicketR shr prj ltkhid)
+        (ProjectR shr prj)
+        (ProjectTicketDiscussionR shr prj ltkhid)
+        (const $ ProjectTicketR shr prj ltkhid)
+    -}
+
 
 
 

templates/cloth/one.cassius

@@ -0,0 +1,19 @@
+/* This file is part of Vervis.
+ *
+ * Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ *
+ * ♡ Copying is an act of love. Please copy, reuse and share.
+ *
+ * The author(s) have dedicated all copyright and related and neighboring
+ * rights to this software to the public domain worldwide. This software is
+ * distributed without any warranty.
+ *
+ * You should have received a copy of the CC0 Public Domain Dedication along
+ * with this software. If not, see
+ * <http://creativecommons.org/publicdomain/zero/1.0/>.
+ */
+
+.#{cRelevant}
+
+.#{cIrrelevant}
+    color: #{light gray}

templates/cloth/one.hamlet

@@ -0,0 +1,127 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2018, 2019, 2020, 2022
+$# by fr33domlover <fr33domlover@riseup.net>.
+$#
+$# ♡ Copying is an act of love. Please copy, reuse and share.
+$#
+$# The author(s) have dedicated all copyright and related and neighboring
+$# rights to this software to the public domain worldwide. This software is
+$# distributed without any warranty.
+$#
+$# You should have received a copy of the CC0 Public Domain Dedication along
+$# with this software. If not, see
+$# <http://creativecommons.org/publicdomain/zero/1.0/>.
+
+<h2>#{preEscapedToHtml $ ticketTitle ticket}
+
+<div>
+  Created on #{showDate $ ticketCreated ticket} by
+  ^{personLinkFedW author}
+
+<div>
+  <span>
+    <a href=@{ClothFollowersR loomHash clothHash}>
+      [🐤 Followers]
+  <span>
+    <a href=@{ClothDepsR loomHash clothHash}>
+      [⤴ Dependencies]
+  <span>
+    <a href=@{ClothReverseDepsR loomHash clothHash}>
+      [⤷ Dependants]
+  <span>
+      [✋ Claim requests]
+  <span>
+      [✏ Edit]
+
+^{followButton}
+
+<div>^{desc}
+
+$# $if ticketStatus ticket /= TSClosed
+$#   <p>
+$#     $maybe (assignee, me) <- massignee
+$#       $if me
+$#         Assigned to you.
+$#
+$#         ^{buttonW POST "Unclaim this ticket" (ProjectTicketUnclaimR loomHash clothHash)}
+$#       $else
+$#         Assigned to ^{sharerLinkW assignee}.
+$#
+$#         ^{buttonW POST "Unassign this ticket" (ProjectTicketUnassignR loomHash clothHash)}
+$#     $nothing
+$#       Not assigned.
+$#
+$#       <a href=@{ClaimRequestNewR loomHash clothHash}>Ask to have it assigned to you
+$#
+$#       or
+$#
+$#       ^{buttonW POST "Claim this ticket" (ProjectTicketClaimR loomHash clothHash)}
+$#
+$#       or
+$#
+$#       <a href=@{ProjectTicketAssignR loomHash clothHash}>Assign to someone else
+$#       .
+
+<p>
+  Status: #
+  $case ticketStatus ticket
+    $of TSNew
+      Open, new.
+
+$#       ^{buttonW POST "Accept this ticket" (ProjectTicketAcceptR loomHash clothHash)}
+$#       ^{buttonW POST "Close this ticket" (ProjectTicketCloseR loomHash clothHash)}
+    $of TSTodo
+      Open, to do.
+
+$#       ^{buttonW POST "Close this ticket" (ProjectTicketCloseR loomHash clothHash)}
+    $of TSClosed
+      Closed on ___ by ___.
+
+$#       ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR loomHash clothHash)}
+
+
+<h3>Custom fields
+
+<ul>
+  $forall TicketTextParam field mvalue <- tparams
+    <li .#{relevant $ wfsFilter field}>
+$#       <a href=@{WorkflowFieldR wshr wfl $ wfsIdent field}>
+        #{wfsName field}
+      :
+      $maybe value <- mvalue
+        #{ttpvVal value}
+      $nothing
+        $if wfsRequired field
+          NO VALUE FOR REQUIRED FIELD
+        $else
+          (none)
+  $forall TicketEnumParam field enum mvalue <- eparams
+    <li .#{relevant $ wfsFilter field}>
+$#       <a href=@{WorkflowFieldR wshr wfl $ wfsIdent field}>
+      #{wfsName field}
+      :
+      $maybe value <- mvalue
+$#         <a href=@{WorkflowEnumCtorsR wshr wfl $ wesIdent enum}>
+          #{tepvName value}
+      $nothing
+        $if wfsRequired field
+          NO VALUE FOR REQUIRED FIELD
+        $else
+          (none)
+  $forall TicketClassParam field mvalue <- cparams
+    <li .#{relevant $ wfsFilter field}>
+$#       <a href=@{WorkflowFieldR wshr wfl $ wfsIdent field}>
+      #{wfsName field}
+      :
+      $maybe _tpcid <- mvalue
+        Yes
+      $nothing
+        No
+
+$# <p>
+$#   ^{buttonW DELETE "Delete this ticket" (ProjectTicketR loomHash clothHash)}
+
+<h3>Discussion
+
+^{discuss}

th/routes

@@ -268,9 +268,9 @@
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unclaim    ClothUnclaimR     POST
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/assign     ClothAssignR      GET POST
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unassign   ClothUnassignR    POST
--- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/follow     ClothFollowR      POST
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/follow     ClothFollowR      POST
--- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unfollow   ClothUnfollowR    POST
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unfollow   ClothUnfollowR    POST
--- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply      ClothTopReplyR    GET POST
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply      ClothReplyR       POST
 
 ---- Cloth Dependency --------------------------------------------------------