vervis/src/Vervis/Handler/Ticket.hs

{- 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
    , postTicketsR
    , 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
    , postTicketDepR
    , deleteTicketDepR
    , getTicketReverseDepsR
    , getTicketParticipantsR
    , getTicketTeamR
    , getTicketEventsR
    )
where

import Prelude

import Control.Applicative (liftA2)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logWarn)
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)
import Text.Blaze.Html.Renderer.Text
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 (..))
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids

import qualified Web.ActivityPub as AP

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

import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph)
import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Model.Workflow
import Vervis.Render
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 (personLinkW)
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")

postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
postTicketsR shar proj = do
    Entity pid project <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shar
        getBy404 $ UniqueProject proj sid
    ((result, widget), enctype) <-
        runFormPost $ newTicketForm $ projectWorkflow project
    case result of
        FormSuccess nt -> do
            author <- requireAuthId
            now <- liftIO getCurrentTime
            let source = ntDesc nt
            descHtml <-
                case renderPandocMarkdown source of
                    Left err -> do
                        setMessage $ toHtml err
                        redirect $ TicketNewR shar proj
                    Right t -> return t
            tnum <- runDB $ do
                update pid [ProjectNextTicket +=. 1]
                did <- insert Discussion
                fsid <- insert FollowerSet
                let ticket = Ticket
                        { ticketProject     = pid
                        , ticketNumber      = projectNextTicket project
                        , ticketCreated     = now
                        , ticketCreator     = author
                        , ticketTitle       = ntTitle nt
                        , ticketSource      = source
                        , ticketDescription = descHtml
                        , ticketAssignee    = Nothing
                        , ticketStatus      = TSNew
                        , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
                        , ticketCloser      = author
                        , ticketDiscuss     = did
                        , ticketFollowers   = fsid
                        }
                tid <- insert ticket
                let mktparam (fid, v) = TicketParamText
                        { ticketParamTextTicket = tid
                        , ticketParamTextField  = fid
                        , ticketParamTextValue  = v
                        }
                insertMany_ $ map mktparam $ ntTParams nt
                let mkeparam (fid, v) = TicketParamEnum
                        { ticketParamEnumTicket = tid
                        , ticketParamEnumField  = fid
                        , ticketParamEnumValue  = v
                        }
                insertMany_ $ map mkeparam $ ntEParams nt
                return $ ticketNumber ticket
            setMessage "Ticket created."
            redirect $ TicketR shar proj tnum
        FormMissing -> do
            setMessage "Field(s) missing."
            defaultLayout $(widgetFile "ticket/new")
        FormFailure _l -> do
            setMessage "Ticket creation failed, see errors below."
            defaultLayout $(widgetFile "ticket/new")

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 shar proj = do
    wid <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shar
        Entity _   j <- getBy404 $ UniqueProject proj 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, closer, 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 <- do
                person <- get404 $ ticketCreator ticket
                get404 $ personIdent person
            massignee <- for (ticketAssignee ticket) $ \ apid -> do
                person <- get404 apid
                sharer <- get404 $ personIdent person
                return (sharer, fromMaybe False $ (== apid) <$> mpid)
            closer <-
                case ticketStatus ticket of
                    TSClosed -> do
                        person <- get404 $ ticketCloser ticket
                        get404 $ personIdent person
                    _ -> return author
            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, closer, 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
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let siblingUri =
            encodeRouteHome . TicketR shar proj . ticketNumber . entityVal
        ticketAP = AP.Ticket
            { AP.ticketId           =
                Just $ encodeRouteLocal $ TicketR shar proj num
            , AP.ticketAttributedTo =
                encodeRouteHome $ SharerR $ sharerIdent author
            , AP.ticketPublished    = Just $ ticketCreated ticket
            , AP.ticketUpdated      = Nothing
            , AP.ticketContext      = encodeRouteLocal $ ProjectR shar proj
            , AP.ticketName         = Just $ "#" <> T.pack (show num)
            , AP.ticketSummary      =
                TextHtml $ TL.toStrict $ renderHtml $ toHtml $
                    ticketTitle ticket
            , AP.ticketContent      = TextHtml $ ticketDescription ticket
            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
            , AP.ticketReplies      =
                encodeRouteLocal $ TicketDiscussionR shar proj num
            , AP.ticketAssignedTo   =
                encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
            , AP.ticketIsResolved   = ticketStatus ticket == TSClosed
            , AP.ticketParticipants =
                encodeRouteLocal $ TicketParticipantsR shar proj num
            , AP.ticketTeam         =
                encodeRouteLocal $ TicketTeamR shar proj num
            , AP.ticketDependsOn    = map siblingUri deps
            , AP.ticketDependedBy   = map siblingUri rdeps
            , AP.ticketEvents       =
                encodeRouteLocal $ TicketEventsR shar proj num
            }
    provideHtmlAndAP ticketAP $(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   =. 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 =. ticketCreator ticket
                    ]
                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]
        [TicketParticipantsR shr prj num, TicketTeamR shr prj num]
        (TicketR shr prj num)
        (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]
        [TicketParticipantsR shr prj num, TicketTeamR shr prj num]
        (TicketR shr prj num)
        (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 Html
getTicketDeps forward shr prj num = do
    let from' =
            if forward then TicketDependencyParent else TicketDependencyChild
        to' =
            if forward then TicketDependencyChild else TicketDependencyParent
    rows <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        Entity tid _ <- getBy404 $ UniqueTicket jid num
        E.select $ E.from $
            \ ( td     `E.InnerJoin`
                ticket `E.InnerJoin`
                person `E.InnerJoin`
                sharer
              ) -> do
                E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
                E.on $ ticket E.^. TicketCreator E.==. person E.^. PersonId
                E.on $ td E.^. to' E.==. ticket E.^. TicketId
                E.where_ $ td E.^. from' E.==. E.val tid
                E.orderBy [E.asc $ ticket E.^. TicketNumber]
                return
                    ( ticket E.^. TicketNumber
                    , sharer
                    , ticket E.^. TicketTitle
                    , ticket E.^. TicketStatus
                    )
    defaultLayout $(widgetFile "ticket/dep/list")

getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
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
            runDB $ do
                let td = TicketDependency
                        { ticketDependencyParent = tid
                        , ticketDependencyChild  = ctid
                        }
                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")

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

deleteTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
deleteTicketDepR 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 Html
getTicketReverseDepsR = getTicketDeps False

getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketParticipantsR shr prj num = do
    (locals, remotes) <- runDB $ do
        sid <- getKeyBy404 $ UniqueSharer shr
        jid <- getKeyBy404 $ UniqueProject prj sid
        t <- getValBy404 $ UniqueTicket jid num
        let fsid = ticketFollowers t
        (,) <$> do  pids <- map (followPerson . entityVal) <$>
                        selectList [FollowTarget ==. fsid] []
                    sids <-
                        map (personIdent . entityVal) <$>
                            selectList [PersonId <-. pids] []
                    map (sharerIdent . entityVal) <$>
                        selectList [SharerId <-. sids] []
            <*> do  E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
                        E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
                        E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
                        E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
                        return
                            ( i E.^. InstanceHost
                            , ra E.^. RemoteActorIdent
                            )

    hLocal <- getsYesod $ appInstanceHost . appSettings
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let doc = Doc hLocal Collection
            { collectionId         =
                encodeRouteLocal $ TicketParticipantsR shr prj num
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ length locals + length remotes
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      =
                map (encodeRouteHome . SharerR) locals ++
                map (uncurry l2f . bimap E.unValue E.unValue) remotes
            }
    selectRep $ do
        provideAP $ pure doc
        provideRep $ defaultLayout $
            [whamlet|
                <div><pre>#{encodePrettyToLazyText doc}
            |]

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] []
    hLocal <- getsYesod $ appInstanceHost . appSettings
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let doc = Doc hLocal Collection
            { collectionId         = encodeRouteLocal $ TicketTeamR shr prj num
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ length memberShrs
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      = map (encodeRouteHome . SharerR) memberShrs
            }
    selectRep $ do
        provideAP $ pure doc
        provideRep $ defaultLayout $
            [whamlet|
                <div><pre>#{encodePrettyToLazyText doc}
            |]
    where
    requireEitherAlt
        :: Applicative f
        => f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)
    requireEitherAlt get1 get2 errNone errBoth = liftA2 mk get1 get2
        where
        mk Nothing  Nothing  = error errNone
        mk (Just _) (Just _) = error errBoth
        mk (Just x) Nothing  = Left x
        mk Nothing  (Just y) = Right y

getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketEventsR shr prj num = error "TODO not implemented"