You are not logged in. Log in. Or Sign up.

NOTE: Federation is disabled on this instance!

You can test federation between the following instances:
Vervis @ dev.angeley.es
HomeSharersfr33domloverReposvervisFilessrcVervisHandler Ticket.hs

Eventually-decentralized project hosting and management platform

[📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Tags

TODO

src / Vervis / Handler /

Ticket.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019 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/>.
 -}

module Vervis.Handler.Ticket
    ( getTicketsR
    , getTicketTreeR
    , getTicketNewR
    , getTicketR
    , putTicketR
    , deleteTicketR
    , postTicketR
    , getTicketEditR
    , postTicketAcceptR
    , postTicketCloseR
    , postTicketOpenR
    , postTicketClaimR
    , postTicketUnclaimR
    , getTicketAssignR
    , postTicketAssignR
    , postTicketUnassignR
    , getClaimRequestsPersonR
    , getClaimRequestsProjectR
    , getClaimRequestsTicketR
    , postClaimRequestsTicketR
    , getClaimRequestNewR
    , getTicketDiscussionR
    , postTicketDiscussionR
    , getMessageR
    , postTicketMessageR
    , getTicketTopReplyR
    , getTicketReplyR
    , getTicketDepsR
    , postTicketDepsR
    , getTicketDepNewR
    , postTicketDepOldR
    , deleteTicketDepOldR
    , getTicketReverseDepsR
    , getTicketDepR
    , getTicketParticipantsR
    , getTicketTeamR
    , getTicketEventsR
    )
where

import Control.Applicative (liftA2)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logWarn)
import Control.Monad.Trans.Except
import Data.Bifunctor
import Data.Bool (bool)
import Data.Default.Class (def)
import Data.Foldable (traverse_)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Traversable (for)
import Database.Persist
import Network.HTTP.Types (StdMethod (DELETE, POST))
import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS
import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Core
import Yesod.Core.Handler
import Yesod.Form.Functions (runFormGet, runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)

import qualified Data.Text as T (filter, intercalate, pack)
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E

import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)

import Data.Aeson.Encode.Pretty.ToEncoding
import Network.FedURI
import Web.ActivityPub hiding (Ticket (..), TicketDependency)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids

import qualified Web.ActivityPub as AP

import Data.Either.Local
import Data.Maybe.Local (partitionMaybePairs)
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.API
import Vervis.Federation
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph)
import Data.MediaType
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Model.Workflow
import Yesod.RenderSource
import Vervis.Settings
import Vervis.Style
import Vervis.Ticket
import Vervis.TicketFilter (filterTickets)
import Vervis.Time (showDate)
import Vervis.Widget (buttonW)
import Vervis.Widget.Discussion (discussionW)
import Vervis.Widget.Sharer
import Vervis.Widget.Ticket

getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
getTicketsR shr prj = do
    ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
    let tf =
            case filtResult of
                FormSuccess filt -> filt
                FormMissing      -> def
                FormFailure l    ->
                    error $ "Ticket filter form failed: " ++ show l
    rows <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        getTicketSummaries
            (filterTickets tf)
            (Just $ \ t -> [E.asc $ t E.^. TicketNumber])
            jid
    defaultLayout $(widgetFile "ticket/list")

getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getTicketTreeR shr prj = do
    (summaries, deps) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        liftA2 (,)
            (getTicketSummaries Nothing Nothing jid)
            (getTicketDepEdges jid)
    defaultLayout $ ticketTreeDW shr prj summaries deps

getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getTicketNewR shr prj = do
    wid <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity _   j <- getBy404 $ UniqueProject prj sid
        return $ projectWorkflow j
    ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
    defaultLayout $(widgetFile "ticket/new")

getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketR shar proj num = do
    mpid <- maybeAuthId
    ( wshr, wfl,
      author, massignee, mcloser, ticket, tparams, eparams, deps, rdeps) <-
        runDB $ do
            (jid, wshr, wid, wfl) <- do
                Entity s sharer <- getBy404 $ UniqueSharer shar
                Entity p project <- getBy404 $ UniqueProject proj s
                w <- get404 $ projectWorkflow project
                wsharer <-
                    if workflowSharer w == s
                        then return sharer
                        else get404 $ workflowSharer w
                return
                    ( p
                    , sharerIdent wsharer
                    , projectWorkflow project
                    , workflowIdent w
                    )
            Entity tid ticket <- getBy404 $ UniqueTicket jid num
            author <-
                requireEitherAlt
                    (do mtal <- getValBy $ UniqueTicketAuthorLocal tid
                        for mtal $ \ tal -> do
                            p <- getJust $ ticketAuthorLocalAuthor tal
                            getJust $ personIdent p
                    )
                    (do mtar <- getValBy $ UniqueTicketAuthorRemote tid
                        for mtar $ \ tar -> do
                            ra <- getJust $ ticketAuthorRemoteAuthor tar
                            ro <- getJust $ remoteActorIdent ra
                            i <- getJust $ remoteObjectInstance ro
                            return (i, ro, ra)
                    )
                    "Ticket doesn't have author"
                    "Ticket has both local and remote author"
            massignee <- for (ticketAssignee ticket) $ \ apid -> do
                person <- get404 apid
                sharer <- get404 $ personIdent person
                return (sharer, fromMaybe False $ (== apid) <$> mpid)
            mcloser <-
                case ticketStatus ticket of
                    TSClosed ->
                        case ticketCloser ticket of
                            Just pidCloser -> Just <$> do
                                person <- getJust pidCloser
                                getJust $ personIdent person
                            Nothing -> error "Closer not set for closed ticket"
                    _ ->
                        case ticketCloser ticket of
                            Just _ -> error "Closer set for open ticket"
                            Nothing -> return Nothing
            tparams <- getTicketTextParams tid wid
            eparams <- getTicketEnumParams tid wid
            deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
                E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
                E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
                return t
            rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
                E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
                E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
                return t
            return
                ( wshr, wfl
                , author, massignee, mcloser, ticket, tparams, eparams
                , deps, rdeps
                )
    encodeHid <- getEncodeKeyHashid
    let desc :: Widget
        desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
        discuss =
            discussionW
                (return $ ticketDiscuss ticket)
                (TicketTopReplyR shar proj num)
                (TicketReplyR shar proj num . encodeHid)
    cRelevant <- newIdent
    cIrrelevant <- newIdent
    let relevant filt =
            bool cIrrelevant cRelevant $
            case ticketStatus ticket of
                TSNew    -> wffNew filt
                TSTodo   -> wffTodo filt
                TSClosed -> wffClosed filt
    hLocal <- getsYesod siteInstanceHost
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let host =
            case author of
                Left _          -> hLocal
                Right (i, _, _) -> instanceHost i
        ticketAP = AP.Ticket
            { AP.ticketLocal        = Just
                ( hLocal
                , AP.TicketLocal
                    { AP.ticketId =
                        encodeRouteLocal $ TicketR shar proj num
                    , AP.ticketContext =
                        encodeRouteLocal $ ProjectR shar proj
                    , AP.ticketReplies =
                        encodeRouteLocal $ TicketDiscussionR shar proj num
                    , AP.ticketParticipants =
                        encodeRouteLocal $ TicketParticipantsR shar proj num
                    , AP.ticketTeam =
                        encodeRouteLocal $ TicketTeamR shar proj num
                    , AP.ticketEvents =
                        encodeRouteLocal $ TicketEventsR shar proj num
                    , AP.ticketDeps =
                        encodeRouteLocal $ TicketDepsR shar proj num
                    , AP.ticketReverseDeps =
                        encodeRouteLocal $ TicketReverseDepsR shar proj num
                    }
                )

            , AP.ticketAttributedTo =
                case author of
                    Left sharer ->
                        encodeRouteLocal $ SharerR $ sharerIdent sharer
                    Right (_inztance, object, _actor) ->
                        remoteObjectIdent object
            , AP.ticketPublished    = Just $ ticketCreated ticket
            , AP.ticketUpdated      = Nothing
            , AP.ticketName         = Just $ "#" <> T.pack (show num)
            , AP.ticketSummary      = TextHtml $ ticketTitle ticket
            , AP.ticketContent      = TextHtml $ ticketDescription ticket
            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
            , AP.ticketAssignedTo   =
                encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
            , AP.ticketIsResolved   = ticketStatus ticket == TSClosed
            }
    provideHtmlAndAP' host ticketAP $
        let followButton =
                followW
                    (TicketFollowR shar proj num)
                    (TicketUnfollowR shar proj num)
                    (return $ ticketFollowers ticket)
        in  $(widgetFile "ticket/one")

putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
putTicketR shar proj num = do
    (tid, ticket, wid) <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shar
        Entity pid project <- getBy404 $ UniqueProject proj sid
        Entity tid ticket <- getBy404 $ UniqueTicket pid num
        return (tid, ticket, projectWorkflow project)
    ((result, widget), enctype) <-
        runFormPost $ editTicketContentForm tid ticket wid
    case result of
        FormSuccess (ticket', tparams, eparams) -> do
            newDescHtml <-
                case renderPandocMarkdown $ ticketSource ticket' of
                    Left err -> do
                        setMessage $ toHtml err
                        redirect $ TicketEditR shar proj num
                    Right t -> return t
            let ticket'' = ticket' { ticketDescription = newDescHtml }
            runDB $ do
                replace tid ticket''
                let (tdel, tins, tupd) = partitionMaybePairs tparams
                deleteWhere [TicketParamTextId <-. tdel]
                let mktparam (fid, v) = TicketParamText
                        { ticketParamTextTicket = tid
                        , ticketParamTextField  = fid
                        , ticketParamTextValue  = v
                        }
                insertMany_ $ map mktparam tins
                traverse_
                    (\ (aid, (_fid, v)) ->
                        update aid [TicketParamTextValue =. v]
                    )
                    tupd
                let (edel, eins, eupd) = partitionMaybePairs eparams
                deleteWhere [TicketParamEnumId <-. edel]
                let mkeparam (fid, v) = TicketParamEnum
                        { ticketParamEnumTicket = tid
                        , ticketParamEnumField  = fid
                        , ticketParamEnumValue  = v
                        }
                insertMany_ $ map mkeparam eins
                traverse_
                    (\ (aid, (_fid, v)) ->
                        update aid [TicketParamEnumValue =. v]
                    )
                    eupd
            setMessage "Ticket updated."
            redirect $ TicketR shar proj num
        FormMissing -> do
            setMessage "Field(s) missing."
            defaultLayout $(widgetFile "ticket/edit")
        FormFailure _l -> do
            setMessage "Ticket update failed, see errors below."
            defaultLayout $(widgetFile "ticket/edit")

deleteTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
deleteTicketR shar proj num =
    --TODO: I can easily implement this, but should it even be possible to
    --delete tickets?
    error "Not implemented"

postTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketR shar proj num = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "PUT"    -> putTicketR shar proj num
        Just "DELETE" -> deleteTicketR shar proj num
        _             -> notFound

getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketEditR shar proj num = do
    (tid, ticket, wid) <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shar
        Entity pid project <- getBy404 $ UniqueProject proj sid
        Entity tid ticket <- getBy404 $ UniqueTicket pid num
        return (tid, ticket, projectWorkflow project)
    ((_result, widget), enctype) <-
        runFormPost $ editTicketContentForm tid ticket wid
    defaultLayout $(widgetFile "ticket/edit")

postTicketAcceptR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketAcceptR shr prj num = do
    succ <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            getBy404 $ UniqueTicket p num
        case ticketStatus ticket of
            TSNew -> do
                update tid [TicketStatus =. TSTodo]
                return True
            _ -> return False
    setMessage $
        if succ
            then "Ticket accepted."
            else "Ticket is already accepted."
    redirect $ TicketR shr prj num

postTicketCloseR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketCloseR shr prj num = do
    pid <- requireAuthId
    now <- liftIO getCurrentTime
    succ <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            getBy404 $ UniqueTicket p num
        case ticketStatus ticket of
            TSClosed -> return False
            _        -> do
                update tid
                    [ TicketAssignee =. Nothing
                    , TicketStatus   =. TSClosed
                    , TicketClosed   =. now
                    , TicketCloser   =. Just pid
                    ]
                return True
    setMessage $
        if succ
            then "Ticket closed."
            else "Ticket is already closed."
    redirect $ TicketR shr prj num

postTicketOpenR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketOpenR shr prj num = do
    pid <- requireAuthId
    now <- liftIO getCurrentTime
    succ <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            getBy404 $ UniqueTicket p num
        case ticketStatus ticket of
            TSClosed -> do
                update tid
                    [ TicketStatus =. TSTodo
                    , TicketCloser =. Nothing
                    ]
                return True
            _        -> return False
    setMessage $
        if succ
            then "Ticket reopened"
            else "Ticket is already open."
    redirect $ TicketR shr prj num

postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketClaimR shr prj num = do
    pid <- requireAuthId
    mmsg <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            getBy404 $ UniqueTicket p num
        case (ticketStatus ticket, ticketAssignee ticket) of
            (TSNew, _) ->
                return $
                Just "The ticket isn’t accepted yet. Can’t claim it."
            (TSClosed, _) ->
                return $
                Just "The ticket is closed. Can’t claim closed tickets."
            (TSTodo, Just _) ->
                return $
                Just "The ticket is already assigned to someone."
            (TSTodo, Nothing) -> do
                update tid [TicketAssignee =. Just pid]
                return Nothing
    setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
    redirect $ TicketR shr prj num

postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketUnclaimR shr prj num = do
    pid <- requireAuthId
    mmsg <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            getBy404 $ UniqueTicket p num
        case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
            (Nothing, _) ->
                return $ Just "The ticket is already unassigned."
            (Just False, _) ->
                return $ Just "The ticket is assigned to someone else."
            (Just True, TSNew) -> do
                $logWarn "Found a new claimed ticket, this is invalid"
                return $
                    Just "The ticket isn’t accepted yet. Can’t unclaim it."
            (Just True, TSClosed) -> do
                $logWarn "Found a closed claimed ticket, this is invalid"
                return $
                    Just "The ticket is closed. Can’t unclaim closed tickets."
            (Just True, TSTodo) -> do
                update tid [TicketAssignee =. Nothing]
                return Nothing
    setMessage $ fromMaybe "The ticket is now unassigned." mmsg
    redirect $ TicketR shr prj num

getTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketAssignR shr prj num = do
    vpid <- requireAuthId
    (jid, Entity tid ticket) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity j _ <- getBy404 $ UniqueProject prj s
        et <- getBy404 $ UniqueTicket j num
        return (j, et)
    let msg t = do
            setMessage t
            redirect $ TicketR shr prj num
    case (ticketStatus ticket, ticketAssignee ticket) of
        (TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
        (TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
        (TSTodo, Just _) -> msg "The ticket is already assigned to someone."
        (TSTodo, Nothing) -> do
            ((_result, widget), enctype) <-
                runFormPost $ assignTicketForm vpid jid
            defaultLayout $(widgetFile "ticket/assign")

postTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketAssignR shr prj num = do
    vpid <- requireAuthId
    (jid, Entity tid ticket) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity j _ <- getBy404 $ UniqueProject prj s
        et <- getBy404 $ UniqueTicket j num
        return (j, et)
    let msg t = do
            setMessage t
            redirect $ TicketR shr prj num
    case (ticketStatus ticket, ticketAssignee ticket) of
        (TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
        (TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
        (TSTodo, Just _) -> msg "The ticket is already assigned to someone."
        (TSTodo, Nothing) -> do
            ((result, widget), enctype) <-
                runFormPost $ assignTicketForm vpid jid
            case result of
                FormSuccess pid -> do
                    sharer <- runDB $ do
                        update tid [TicketAssignee =. Just pid]
                        person <- getJust pid
                        getJust $ personIdent person
                    let si = sharerIdent sharer
                    msg $ toHtml $
                        "The ticket is now assigned to " <> shr2text si <> "."
                FormMissing -> do
                    setMessage "Field(s) missing."
                    defaultLayout $(widgetFile "ticket/assign")
                FormFailure _l -> do
                    setMessage "Ticket assignment failed, see errors below."
                    defaultLayout $(widgetFile "ticket/assign")

postTicketUnassignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketUnassignR shr prj num = do
    pid <- requireAuthId
    mmsg <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            getBy404 $ UniqueTicket p num
        case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
            (Nothing, _) ->
                return $ Just "The ticket is already unassigned."
            (Just True, _) ->
                return $ Just "The ticket is assigned to you, unclaim instead."
            (Just False, TSNew) -> do
                $logWarn "Found a new claimed ticket, this is invalid"
                return $
                    Just "The ticket isn’t accepted yet. Can’t unclaim it."
            (Just False, TSClosed) -> do
                $logWarn "Found a closed claimed ticket, this is invalid"
                return $
                    Just "The ticket is closed. Can’t unclaim closed tickets."
            (Just False, TSTodo) -> do
                update tid [TicketAssignee =. Nothing]
                return Nothing
    setMessage $ fromMaybe "The ticket is now unassigned." mmsg
    redirect $ TicketR shr prj num

-- | The logged-in user gets a list of the ticket claim requests they have
-- opened, in any project.
getClaimRequestsPersonR :: Handler Html
getClaimRequestsPersonR = do
    pid <- requireAuthId
    rqs <- runDB $ E.select $ E.from $
        \ (tcr `E.InnerJoin` ticket `E.InnerJoin` project `E.InnerJoin` sharer) -> do
            E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId
            E.on $ ticket E.^. TicketProject E.==. project E.^. ProjectId
            E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
            E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid
            E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
            return
                ( sharer E.^. SharerIdent
                , project E.^. ProjectIdent
                , ticket E.^. TicketNumber
                , ticket E.^. TicketTitle
                , tcr E.^. TicketClaimRequestCreated
                )
    defaultLayout $(widgetFile "person/claim-requests")

-- | Get a list of ticket claim requests for a given project.
getClaimRequestsProjectR :: ShrIdent -> PrjIdent -> Handler Html
getClaimRequestsProjectR shr prj = do
    rqs <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        E.select $ E.from $
            \ ( tcr    `E.InnerJoin`
                ticket `E.InnerJoin`
                person `E.InnerJoin`
                sharer
              ) -> do
                E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
                E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
                E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
                E.where_ $ ticket E.^. TicketProject E.==. E.val jid
                E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
                return
                    ( sharer
                    , ticket E.^. TicketNumber
                    , ticket E.^. TicketTitle
                    , tcr E.^. TicketClaimRequestCreated
                    )
    defaultLayout $(widgetFile "project/claim-request/list")

-- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getClaimRequestsTicketR shr prj num = do
    rqs <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
                E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
                E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
                E.where_ $ tcr E.^. TicketClaimRequestTicket E.==. E.val tid
                E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
                return (sharer, tcr)
    defaultLayout $(widgetFile "ticket/claim-request/list")

getClaimRequestNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getClaimRequestNewR shr prj num = do
    ((_result, widget), etype) <- runFormPost claimRequestForm
    defaultLayout $(widgetFile "ticket/claim-request/new")

postClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postClaimRequestsTicketR shr prj num = do
    ((result, widget), etype) <- runFormPost claimRequestForm
    case result of
        FormSuccess msg -> do
            now <- liftIO getCurrentTime
            pid <- requireAuthId
            runDB $ do
                tid <- do
                    Entity s _ <- getBy404 $ UniqueSharer shr
                    Entity j _ <- getBy404 $ UniqueProject prj s
                    Entity t _ <- getBy404 $ UniqueTicket j num
                    return t
                let cr = TicketClaimRequest
                        { ticketClaimRequestPerson  = pid
                        , ticketClaimRequestTicket  = tid
                        , ticketClaimRequestMessage = msg
                        , ticketClaimRequestCreated = now
                        }
                insert_ cr
            setMessage "Ticket claim request opened."
            redirect $ TicketR shr prj num
        FormMissing -> do
            setMessage "Field(s) missing."
            defaultLayout $(widgetFile "ticket/claim-request/new")
        FormFailure _l -> do
            setMessage "Submission failed, see errors below."
            defaultLayout $(widgetFile "ticket/claim-request/new")

selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId
selectDiscussionId shar proj tnum = do
    Entity sid _sharer <- getBy404 $ UniqueSharer shar
    Entity pid _project <- getBy404 $ UniqueProject proj sid
    Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum
    return $ ticketDiscuss ticket

getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDiscussionR shar proj num = do
    encodeHid <- getEncodeKeyHashid
    getDiscussion
        (TicketReplyR shar proj num . encodeHid)
        (TicketTopReplyR shar proj num)
        (selectDiscussionId shar proj num)

postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketDiscussionR shr prj num = do
    hLocal <- getsYesod $ appInstanceHost . appSettings
    postTopReply
        hLocal
        [ProjectR shr prj]
        [ ProjectFollowersR shr prj
        , TicketParticipantsR shr prj num
        , TicketTeamR shr prj num
        ]
        (TicketR shr prj num)
        (ProjectR shr prj)
        (TicketDiscussionR shr prj num)
        (const $ TicketR shr prj num)

getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
getMessageR shr hid = do
    lmid <- decodeKeyHashid404 hid
    getDiscussionMessage shr lmid

postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
postTicketMessageR shr prj num mkhid = do
    encodeHid <- getEncodeKeyHashid
    mid <- decodeKeyHashid404 mkhid
    hLocal <- getsYesod $ appInstanceHost . appSettings
    postReply
        hLocal
        [ProjectR shr prj]
        [ ProjectFollowersR shr prj
        , TicketParticipantsR shr prj num
        , TicketTeamR shr prj num
        ]
        (TicketR shr prj num)
        (ProjectR shr prj)
        (TicketReplyR shr prj num . encodeHid)
        (TicketMessageR shr prj num . encodeHid)
        (const $ TicketR shr prj num)
        (selectDiscussionId shr prj num)
        mid

getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketTopReplyR shar proj num =
    getTopReply $ TicketDiscussionR shar proj num

getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
getTicketReplyR shar proj tnum hid = do
    encodeHid <- getEncodeKeyHashid
    mid <- decodeKeyHashid404 hid
    getReply
        (TicketReplyR shar proj tnum . encodeHid)
        (TicketMessageR shar proj tnum . encodeHid)
        (selectDiscussionId shar proj tnum)
        mid

getTicketDeps :: Bool -> ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketDeps forward shr prj num = do
    (deps, rows) <- unzip <$> runDB getDepsFromDB
    depsAP <- makeDepsCollection deps
    provideHtmlAndAP depsAP $(widgetFile "ticket/dep/list")
    where
    getDepsFromDB = do
        let from' =
                if forward then TicketDependencyParent else TicketDependencyChild
            to' =
                if forward then TicketDependencyChild else TicketDependencyParent
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        fmap (map toRow) $ E.select $ E.from $
            \ ( td
              `E.InnerJoin` t
              `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
              `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
              ) -> do
                E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId
                E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId
                E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
                E.on $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket
                E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
                E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
                E.on $ E.just (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket
                E.on $ td E.^. to' E.==. t E.^. TicketId
                E.where_ $ td E.^. from' E.==. E.val tid
                E.orderBy [E.asc $ t E.^. TicketNumber]
                return
                    ( td E.^. TicketDependencyId
                    , t E.^. TicketNumber
                    , s
                    , i
                    , ro
                    , ra
                    , t E.^. TicketTitle
                    , t E.^. TicketStatus
                    )
        where
        toRow (E.Value dep, E.Value number, ms, mi, mro, mra, E.Value title, E.Value status) =
            ( dep
            , ( number
              , case (ms, mi, mro, mra) of
                  (Just s, Nothing, Nothing, Nothing) ->
                      Left $ entityVal s
                  (Nothing, Just i, Just ro, Just ra) ->
                      Right (entityVal i, entityVal ro, entityVal ra)
                  _ -> error "Ticket author DB invalid state"
              , title
              , status
              )
            )
    makeDepsCollection tdids = do
        encodeRouteLocal <- getEncodeRouteLocal
        encodeRouteHome <- getEncodeRouteHome
        encodeKeyHashid <- getEncodeKeyHashid
        let here =
                let route = if forward then TicketDepsR else TicketReverseDepsR
                in  route shr prj num
        return Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ length tdids
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      =
                map (encodeRouteHome . TicketDepR . encodeKeyHashid) tdids
            }

getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketDepsR = getTicketDeps True

postTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketDepsR shr prj num = do
    (jid, tid) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        return (jid, tid)
    ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
    case result of
        FormSuccess ctid -> do
            pidAuthor <- requireVerifiedAuthId
            now <- liftIO getCurrentTime
            runDB $ do
                let td = TicketDependency
                        { ticketDependencyParent  = tid
                        , ticketDependencyChild   = ctid
                        , ticketDependencyAuthor  = pidAuthor
                        , ticketDependencySummary = "(A ticket dependency)"
                        , ticketDependencyCreated = now
                        }
                insert_ td
                trrFix td ticketDepGraph
            setMessage "Ticket dependency added."
            redirect $ TicketR shr prj num
        FormMissing -> do
            setMessage "Field(s) missing."
            defaultLayout $(widgetFile "ticket/dep/new")
        FormFailure _l -> do
            setMessage "Submission failed, see errors below."
            defaultLayout $(widgetFile "ticket/dep/new")

getTicketDepNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDepNewR shr prj num = do
    (jid, tid) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        return (jid, tid)
    ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
    defaultLayout $(widgetFile "ticket/dep/new")

postTicketDepOldR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
postTicketDepOldR shr prj pnum cnum = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "DELETE" -> deleteTicketDepOldR shr prj pnum cnum
        _             -> notFound

deleteTicketDepOldR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do
    runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity ptid _ <- getBy404 $ UniqueTicket jid pnum
        Entity ctid _ <- getBy404 $ UniqueTicket jid cnum
        Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
        delete tdid
    setMessage "Ticket dependency removed."
    redirect $ TicketDepsR shr prj pnum

getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketReverseDepsR = getTicketDeps False

getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent
getTicketDepR tdkhid = do
    tdid <- decodeKeyHashid404 tdkhid
    ( td,
      (sParent, jParent, tParent),
      (sChild, jChild, tChild),
      (sAuthor, pAuthor)
      ) <- runDB $ do
        tdep <- get404 tdid
        (,,,) tdep
            <$> getTicket (ticketDependencyParent tdep)
            <*> getTicket (ticketDependencyChild tdep)
            <*> getAuthor (ticketDependencyAuthor tdep)

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let ticketRoute s j t =
            TicketR (sharerIdent s) (projectIdent j) (ticketNumber t)
        here = TicketDepR tdkhid
        tdepAP = AP.TicketDependency
            { ticketDepId           = Just $ encodeRouteHome here
            , ticketDepParent       =
                encodeRouteHome $ ticketRoute sParent jParent tParent
            , ticketDepChild        =
                encodeRouteHome $ ticketRoute sChild jChild tChild
            , ticketDepAttributedTo =
                encodeRouteLocal $ SharerR $ sharerIdent sAuthor
            , ticketDepPublished    = Just $ ticketDependencyCreated td
            , ticketDepUpdated      = Just $ ticketDependencyCreated td
            , ticketDepSummary      = TextHtml $ ticketDependencySummary td
            }

    provideHtmlAndAP tdepAP $ redirectToPrettyJSON here
    where
    getTicket tid = do
        t <- getJust tid
        j <- getJust $ ticketProject t
        s <- getJust $ projectSharer j
        return (s, j, t)
    getAuthor pid = do
        p <- getJust pid
        s <- getJust $ personIdent p
        return (s, p)

getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketParticipantsR shr prj num = getFollowersCollection here getFsid
    where
    here = TicketParticipantsR shr prj num
    getFsid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        jid <- getKeyBy404 $ UniqueProject prj sid
        t <- getValBy404 $ UniqueTicket jid num
        return $ ticketFollowers t

getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketTeamR shr prj num = do
    memberShrs <- runDB $ do
        sid <- getKeyBy404 $ UniqueSharer shr
        _jid <- getKeyBy404 $ UniqueProject prj sid
        _tid <- getKeyBy404 $ UniqueTicket _jid num
        id_ <-
            requireEitherAlt
                (getKeyBy $ UniquePersonIdent sid)
                (getKeyBy $ UniqueGroup sid)
                "Found sharer that is neither person nor group"
                "Found sharer that is both person and group"
        case id_ of
            Left pid -> return [shr]
            Right gid -> do
                pids <-
                    map (groupMemberPerson . entityVal) <$>
                        selectList [GroupMemberGroup ==. gid] []
                sids <-
                    map (personIdent . entityVal) <$>
                        selectList [PersonId <-. pids] []
                map (sharerIdent . entityVal) <$>
                    selectList [SharerId <-. sids] []

    let here = TicketTeamR shr prj num

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let team = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ length memberShrs
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      = map (encodeRouteHome . SharerR) memberShrs
            }
    provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])

getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketEventsR shr prj num = error "TODO not implemented"
[See repo JSON]