vervis/src/Vervis/Handler/Ticket.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018, 2019, 2020 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

    , getSharerTicketsR
    , getSharerTicketR
    , getSharerTicketDiscussionR
    , getSharerTicketDepsR
    , getSharerTicketReverseDepsR
    , getSharerTicketFollowersR
    , getSharerTicketTeamR
    , getSharerTicketEventsR
    )
where

import Control.Applicative (liftA2)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Data.Aeson (encode)
import Data.Bifunctor
import Data.Bitraversable
import Data.Bool (bool)
import Data.Default.Class (def)
import Data.Foldable (traverse_)
import Data.Maybe
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 hiding (logWarn)
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.ByteString.Lazy as BL
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 Data.MediaType
import Network.FedURI
import Web.ActivityPub hiding (Ticket (..), TicketDependency)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource

import qualified Web.ActivityPub as AP

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

import Vervis.API
import Vervis.Federation
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Model.Workflow
import Vervis.Paginate
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 TypedContent
getTicketsR shr prj = selectRep $ do
    provideRep $ 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
        (total, pages, mpage) <- runDB $ do
            Entity sid _ <- getBy404 $ UniqueSharer shr
            Entity jid _ <- getBy404 $ UniqueProject prj sid
            let countAllTickets = count [TicketProjectLocalProject ==. jid]
                selectTickets off lim =
                    getTicketSummaries
                        (filterTickets tf)
                        (Just $ \ t -> [E.asc $ t E.^. TicketId])
                        (Just (off, lim))
                        jid
            getPageAndNavCount countAllTickets selectTickets
        case mpage of
            Nothing -> redirectFirstPage here
            Just (rows, navModel) ->
                let pageNav = navWidget navModel
                in  defaultLayout $(widgetFile "ticket/list")
    provideAP' $ do
        (total, pages, mpage) <- runDB $ do
            Entity sid _ <- getBy404 $ UniqueSharer shr
            Entity jid _ <- getBy404 $ UniqueProject prj sid
            let countAllTickets = count [TicketProjectLocalProject ==. jid]
                selectTickets off lim = do
                    tids <-
                        map (ticketProjectLocalTicket . entityVal) <$>
                            selectList
                                [TicketProjectLocalProject ==. jid]
                                [ Desc TicketProjectLocalTicket
                                , OffsetBy off
                                , LimitTo lim
                                ]
                    selectKeysList [LocalTicketTicket <-. tids] [Desc LocalTicketTicket]
            getPageAndNavCount countAllTickets selectTickets

        encodeRouteHome <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal
        encodeRoutePageLocal <- getEncodeRoutePageLocal
        let pageUrl = encodeRoutePageLocal here
        host <- asksSite siteInstanceHost
        encodeTicketKey <- getEncodeKeyHashid
        let ticketUrl = TicketR shr prj . encodeTicketKey

        return $
            case mpage of
                Nothing -> encodeStrict $ Doc host $ Collection
                    { collectionId         = encodeRouteLocal here
                    , collectionType       = CollectionTypeOrdered
                    , collectionTotalItems = Just total
                    , collectionCurrent    = Nothing
                    , collectionFirst      = Just $ pageUrl 1
                    , collectionLast       = Just $ pageUrl pages
                    , collectionItems      = [] :: [Text]
                    }
                Just (tickets, navModel) ->
                    let current = nmCurrent navModel
                    in  encodeStrict $ Doc host $ CollectionPage
                            { collectionPageId         = pageUrl current
                            , collectionPageType       = CollectionPageTypeOrdered
                            , collectionPageTotalItems = Nothing
                            , collectionPageCurrent    = Just $ pageUrl current
                            , collectionPageFirst      = Just $ pageUrl 1
                            , collectionPageLast       = Just $ pageUrl pages
                            , collectionPagePartOf     = encodeRouteLocal here
                            , collectionPagePrev       =
                                if current > 1
                                    then Just $ pageUrl $ current - 1
                                    else Nothing
                            , collectionPageNext       =
                                if current < pages
                                    then Just $ pageUrl $ current + 1
                                    else Nothing
                            , collectionPageStartIndex = Nothing
                            , collectionPageItems      =
                                map (encodeRouteHome . ticketUrl) tickets
                            }
    where
    here = TicketsR shr prj
    encodeStrict = BL.toStrict . encode

getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getTicketTreeR shr prj = do
    (summaries, deps) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        (,) <$> getTicketSummaries Nothing 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 -> KeyHashid LocalTicket -> Handler TypedContent
getTicketR shar proj ltkhid = do
    mpid <- maybeAuthId
    ( wshr, wfl,
      author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
      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
                    )
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            Entity tplid tpl <- getBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == jid) notFound
            author <-
                requireEitherAlt
                    (do mtal <- getValBy $ UniqueTicketAuthorLocal ltid
                        for mtal $ \ tal -> do
                            _ <- getBy404 $ UniqueTicketUnderProjectProject tplid
                            p <- getJust $ ticketAuthorLocalAuthor tal
                            getJust $ personIdent p
                    )
                    (do mtar <- getValBy $ UniqueTicketAuthorRemote tplid
                        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"
            ticket <- get404 tid
            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
            cparams <- getTicketClasses tid wid
            deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
                E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
                E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
                E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
                return (lt E.^. LocalTicketId, t)
            rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
                E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
                E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
                E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
                return (lt E.^. LocalTicketId, t)
            return
                ( wshr, wfl
                , author, massignee, mcloser, ticket, lticket
                , tparams, eparams, cparams
                , deps, rdeps
                )
    encodeHid <- getEncodeKeyHashid
    let desc :: Widget
        desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
        discuss =
            discussionW
                (return $ localTicketDiscuss lticket)
                (TicketTopReplyR shar proj ltkhid)
                (TicketReplyR shar proj ltkhid . 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 ltkhid
                    , AP.ticketContext =
                        encodeRouteLocal $ ProjectR shar proj
                    , AP.ticketReplies =
                        encodeRouteLocal $ TicketDiscussionR shar proj ltkhid
                    , AP.ticketParticipants =
                        encodeRouteLocal $ TicketParticipantsR shar proj ltkhid
                    , AP.ticketTeam =
                        encodeRouteLocal $ TicketTeamR shar proj ltkhid
                    , AP.ticketEvents =
                        encodeRouteLocal $ TicketEventsR shar proj ltkhid
                    , AP.ticketDeps =
                        encodeRouteLocal $ TicketDepsR shar proj ltkhid
                    , AP.ticketReverseDeps =
                        encodeRouteLocal $ TicketReverseDepsR shar proj ltkhid
                    }
                )

            , 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 ltkhid)
                    (TicketUnfollowR shar proj ltkhid)
                    (return $ localTicketFollowers lticket)
        in  $(widgetFile "ticket/one")

putTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
putTicketR shr prj ltkhid = do
    (tid, ticket, wid) <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shr
        Entity pid project <- getBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        ticket <- getJust tid
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == pid) notFound
        return (tid, ticket, projectWorkflow project)
    ((result, widget), enctype) <-
        runFormPost $ editTicketContentForm tid ticket wid
    case result of
        FormSuccess (ticket', tparams, eparams, cparams) -> do
            newDescHtml <-
                case renderPandocMarkdown $ ticketSource ticket' of
                    Left err -> do
                        setMessage $ toHtml err
                        redirect $ TicketEditR shr prj ltkhid
                    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
                let (cdel, cins, _ckeep) = partitionMaybePairs cparams
                deleteWhere [TicketParamClassId <-. cdel]
                let mkcparam fid = TicketParamClass
                        { ticketParamClassTicket = tid
                        , ticketParamClassField  = fid
                        }
                insertMany_ $ map mkcparam cins
            setMessage "Ticket updated."
            redirect $ TicketR shr prj ltkhid
        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 -> KeyHashid LocalTicket -> Handler Html
deleteTicketR _shr _prj _ltkhid =
    --TODO: I can easily implement this, but should it even be possible to
    --delete tickets?
    error "Not implemented"

postTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketR shr prj ltkhid = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "PUT"    -> putTicketR shr prj ltkhid
        Just "DELETE" -> deleteTicketR shr prj ltkhid
        _             -> notFound

getTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketEditR shr prj ltkhid = do
    (tid, ticket, wid) <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shr
        Entity pid project <- getBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        ticket <- getJust tid
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == pid) notFound
        return (tid, ticket, projectWorkflow project)
    ((_result, widget), enctype) <-
        runFormPost $ editTicketContentForm tid ticket wid
    defaultLayout $(widgetFile "ticket/edit")

postTicketAcceptR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketAcceptR shr prj ltkhid = do
    succ <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            ticket <- getJust tid
            tpl <- getValBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == p) notFound
            return $ Entity tid ticket
        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 ltkhid

postTicketCloseR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketCloseR shr prj ltkhid = do
    pid <- requireAuthId
    now <- liftIO getCurrentTime
    succ <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            ticket <- getJust tid
            tpl <- getValBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == p) notFound
            return $ Entity tid ticket
        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 ltkhid

postTicketOpenR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketOpenR shr prj ltkhid = do
    pid <- requireAuthId
    now <- liftIO getCurrentTime
    succ <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            ticket <- getJust tid
            tpl <- getValBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == p) notFound
            return $ Entity tid ticket
        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 ltkhid

postTicketClaimR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketClaimR shr prj ltkhid = do
    pid <- requireAuthId
    mmsg <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            ticket <- getJust tid
            tpl <- getValBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == p) notFound
            return $ Entity tid ticket
        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 ltkhid

postTicketUnclaimR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketUnclaimR shr prj ltkhid = do
    pid <- requireAuthId
    mmsg <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            ticket <- getJust tid
            tpl <- getValBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == p) notFound
            return $ Entity tid ticket
        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 ltkhid

getTicketAssignR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketAssignR shr prj ltkhid = do
    vpid <- requireAuthId
    (jid, Entity tid ticket) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity j _ <- getBy404 $ UniqueProject prj s
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        ticket <- getJust tid
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == j) notFound
        return (j, Entity tid ticket)
    let msg t = do
            setMessage t
            redirect $ TicketR shr prj ltkhid
    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 -> KeyHashid LocalTicket -> Handler Html
postTicketAssignR shr prj ltkhid = do
    vpid <- requireAuthId
    (jid, Entity tid ticket) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity j _ <- getBy404 $ UniqueProject prj s
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        ticket <- getJust tid
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == j) notFound
        return (j, Entity tid ticket)
    let msg t = do
            setMessage t
            redirect $ TicketR shr prj ltkhid
    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 -> KeyHashid LocalTicket -> Handler Html
postTicketUnassignR shr prj ltkhid = do
    pid <- requireAuthId
    mmsg <- runDB $ do
        Entity tid ticket <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity p _ <- getBy404 $ UniqueProject prj s
            ltid <- decodeKeyHashid404 ltkhid
            lticket <- get404 ltid
            let tid = localTicketTicket lticket
            ticket <- getJust tid
            tpl <- getValBy404 $ UniqueTicketProjectLocal tid
            unless (ticketProjectLocalProject tpl == p) notFound
            return $ Entity tid ticket
        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 ltkhid

-- | 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` lticket `E.InnerJoin` tpl `E.InnerJoin` project `E.InnerJoin` sharer) -> do
            E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId
            E.on $ tpl E.^. TicketProjectLocalProject E.==. project E.^. ProjectId
            E.on $ ticket E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
            E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket
            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
                , lticket E.^. LocalTicketId
                , ticket E.^. TicketTitle
                , tcr E.^. TicketClaimRequestCreated
                )
    encodeHid <- getEncodeKeyHashid
    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`
                lticket `E.InnerJoin`
                tpl     `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 $ ticket E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
                E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket
                E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
                E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid
                E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
                return
                    ( sharer
                    , lticket E.^. LocalTicketId
                    , ticket E.^. TicketTitle
                    , tcr E.^. TicketClaimRequestCreated
                    )
    encodeHid <- getEncodeKeyHashid
    defaultLayout $(widgetFile "project/claim-request/list")

-- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getClaimRequestsTicketR shr prj ltkhid = do
    rqs <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == jid) notFound
        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 -> KeyHashid LocalTicket -> Handler Html
getClaimRequestNewR shr prj ltkhid = do
    ((_result, widget), etype) <- runFormPost claimRequestForm
    defaultLayout $(widgetFile "ticket/claim-request/new")

postClaimRequestsTicketR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postClaimRequestsTicketR shr prj ltkhid = 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
                    ltid <- decodeKeyHashid404 ltkhid
                    lticket <- get404 ltid
                    let tid = localTicketTicket lticket
                    tpl <- getValBy404 $ UniqueTicketProjectLocal tid
                    unless (ticketProjectLocalProject tpl == j) notFound
                    return tid
                let cr = TicketClaimRequest
                        { ticketClaimRequestPerson  = pid
                        , ticketClaimRequestTicket  = tid
                        , ticketClaimRequestMessage = msg
                        , ticketClaimRequestCreated = now
                        }
                insert_ cr
            setMessage "Ticket claim request opened."
            redirect $ TicketR shr prj ltkhid
        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 -> KeyHashid LocalTicket -> AppDB DiscussionId
selectDiscussionId shr prj ltkhid = do
    Entity sid _sharer <- getBy404 $ UniqueSharer shr
    Entity jid _project <- getBy404 $ UniqueProject prj sid
    ltid <- decodeKeyHashid404 ltkhid
    lticket <- get404 ltid
    let tid = localTicketTicket lticket
    tpl <- getValBy404 $ UniqueTicketProjectLocal tid
    unless (ticketProjectLocalProject tpl == jid) notFound
    return $ localTicketDiscuss lticket

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

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

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

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

getTicketTopReplyR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketTopReplyR shr prj ltkhid =
    getTopReply $ TicketDiscussionR shr prj ltkhid

getTicketReplyR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid Message -> Handler Html
getTicketReplyR shr prj ltkhid mkhid = do
    encodeHid <- getEncodeKeyHashid
    mid <- decodeKeyHashid404 mkhid
    getReply
        (TicketReplyR shr prj ltkhid . encodeHid)
        (TicketMessageR shr prj ltkhid . encodeHid)
        (selectDiscussionId shr prj ltkhid)
        mid

getTicketDeps
    :: Bool -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDeps forward shr prj ltkhid = do
    (deps, rows) <- unzip <$> runDB getDepsFromDB
    depsAP <- makeDepsCollection deps
    encodeHid <- getEncodeKeyHashid
    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
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == jid) notFound
        fmap (map toRow) $ E.select $ E.from $
            \ ( td
              `E.InnerJoin` t
              `E.InnerJoin` lt
              `E.InnerJoin` tpl
              `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 (tpl E.^. TicketProjectLocalId) 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 (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
                E.on $ t E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
                E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
                E.on $ td E.^. to' E.==. t E.^. TicketId
                E.where_ $ td E.^. from' E.==. E.val tid
                E.orderBy [E.asc $ t E.^. TicketId]
                return
                    ( td E.^. TicketDependencyId
                    , lt E.^. LocalTicketId
                    , s
                    , i
                    , ro
                    , ra
                    , t E.^. TicketTitle
                    , t E.^. TicketStatus
                    )
        where
        toRow (E.Value dep, E.Value ltid, ms, mi, mro, mra, E.Value title, E.Value status) =
            ( dep
            , ( ltid
              , 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 ltkhid
        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 -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDepsR = getTicketDeps True

postTicketDepsR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketDepsR shr prj ltkhid = do
    (jid, tid) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == jid) notFound
        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 ltkhid
        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 -> KeyHashid LocalTicket -> Handler Html
getTicketDepNewR shr prj ltkhid = do
    (jid, tid) <- runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lticket <- get404 ltid
        let tid = localTicketTicket lticket
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == jid) notFound
        return (jid, tid)
    ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
    defaultLayout $(widgetFile "ticket/dep/new")

postTicketDepOldR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> 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 -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do
    runDB $ do
        Entity sid _ <- getBy404 $ UniqueSharer shr
        Entity jid _ <- getBy404 $ UniqueProject prj sid

        pltid <- decodeKeyHashid404 pnum
        plt <- get404 pltid
        let ptid = localTicketTicket plt
        ptpl <- getValBy404 $ UniqueTicketProjectLocal ptid
        unless (ticketProjectLocalProject ptpl == jid) notFound

        cltid <- decodeKeyHashid404 cnum
        clt <- get404 cltid
        let ctid = localTicketTicket clt
        ctpl <- getValBy404 $ UniqueTicketProjectLocal ctid
        unless (ticketProjectLocalProject ctpl == jid) notFound

        Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
        delete tdid
    setMessage "Ticket dependency removed."
    redirect $ TicketDepsR shr prj pnum

getTicketReverseDepsR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketReverseDepsR = getTicketDeps False

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

    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    encodeHid <- getEncodeKeyHashid
    let ticketRoute s j lt =
            TicketR (sharerIdent s) (projectIdent j) (encodeHid lt)
        here = TicketDepR tdkhid
        tdepAP = AP.TicketDependency
            { ticketDepId           = Just $ encodeRouteHome here
            , ticketDepParent       =
                encodeRouteHome $ ticketRoute sParent jParent ltParent
            , ticketDepChild        =
                encodeRouteHome $ ticketRoute sChild jChild ltChild
            , 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
        ltid <- do
            mltid <- getKeyBy $ UniqueLocalTicket tid
            case mltid of
                Nothing -> error "No LocalTicket"
                Just v -> return v
        tpl <- do
            mtpl <- getValBy $ UniqueTicketProjectLocal tid
            case mtpl of
                Nothing -> error "No TicketProjectLocal"
                Just v -> return v
        j <- getJust $ ticketProjectLocalProject tpl
        s <- getJust $ projectSharer j
        return (s, j, ltid)
    getAuthor pid = do
        p <- getJust pid
        s <- getJust $ personIdent p
        return (s, p)

getTicketParticipantsR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFsid
    where
    here = TicketParticipantsR shr prj ltkhid
    getFsid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        jid <- getKeyBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lt <- get404 ltid
        let tid = localTicketTicket lt
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == jid) notFound
        return $ localTicketFollowers lt

getTicketTeamR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketTeamR shr prj ltkhid = do
    memberShrs <- runDB $ do
        sid <- getKeyBy404 $ UniqueSharer shr
        jid <- getKeyBy404 $ UniqueProject prj sid
        ltid <- decodeKeyHashid404 ltkhid
        lt <- get404 ltid
        let tid = localTicketTicket lt
        tpl <- getValBy404 $ UniqueTicketProjectLocal tid
        unless (ticketProjectLocalProject tpl == jid) notFound
        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 ltkhid

    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 $ redirectToPrettyJSON here

getTicketEventsR
    :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"

getSharerTicket
    :: ShrIdent
    -> KeyHashid TicketAuthorLocal
    -> AppDB
        ( Entity TicketAuthorLocal
        , Entity LocalTicket
        , Entity Ticket
        , Either (Entity TicketProjectLocal) ()
        )
getSharerTicket shr talkhid = do
    pid <- do
        sid <- getKeyBy404 $ UniqueSharer shr
        getKeyBy404 $ UniquePersonIdent sid
    talid <- decodeKeyHashid404 talkhid
    tal <- get404 talid
    unless (ticketAuthorLocalAuthor tal == pid) notFound
    let ltid = ticketAuthorLocalTicket tal
    lt <- getJust ltid
    let tid = localTicketTicket lt
    t <- getJust tid
    project <-
        requireEitherAlt
            (do mtpl <- getBy $ UniqueTicketProjectLocal tid
                for mtpl $ \ etpl@(Entity tplid tpl) -> do
                    mtup1 <- getBy $ UniqueTicketUnderProjectProject tplid
                    mtup2 <- getBy $ UniqueTicketUnderProjectAuthor talid
                    unless (isJust mtup1 == isJust mtup2) $
                        error "TUP points to unrelated TAL and TPL!"
                    unless (isNothing mtup1) notFound
                    return etpl
            )
            (return Nothing
            )
            "Ticket doesn't have project"
            "Ticket has both local and remote project"
    return (Entity talid tal, Entity ltid lt, Entity tid t, project)

getSharerTicketsR :: ShrIdent -> Handler TypedContent
getSharerTicketsR shr = do
    (total, pages, mpage) <- runDB $ do
        sid <- getKeyBy404 $ UniqueSharer shr
        pid <- getKeyBy404 $ UniquePersonIdent sid
        getPageAndNavCount (countTickets pid) (selectTickets pid)
    encodeRouteHome <- getEncodeRouteHome
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRoutePageLocal <- getEncodeRoutePageLocal
    let pageUrl = encodeRoutePageLocal here
    encodeTicketKey <- getEncodeKeyHashid
    let ticketUrl = SharerTicketR shr . encodeTicketKey

    case mpage of
        Nothing -> provide $ Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeOrdered
            , collectionTotalItems = Just total
            , collectionCurrent    = Nothing
            , collectionFirst      = Just $ pageUrl 1
            , collectionLast       = Just $ pageUrl pages
            , collectionItems      = [] :: [Text]
            }
        Just (tickets, navModel) ->
            let current = nmCurrent navModel
            in  provide $ CollectionPage
                    { collectionPageId         = pageUrl current
                    , collectionPageType       = CollectionPageTypeOrdered
                    , collectionPageTotalItems = Nothing
                    , collectionPageCurrent    = Just $ pageUrl current
                    , collectionPageFirst      = Just $ pageUrl 1
                    , collectionPageLast       = Just $ pageUrl pages
                    , collectionPagePartOf     = encodeRouteLocal here
                    , collectionPagePrev       =
                        if current > 1
                            then Just $ pageUrl $ current - 1
                            else Nothing
                    , collectionPageNext       =
                        if current < pages
                            then Just $ pageUrl $ current + 1
                            else Nothing
                    , collectionPageStartIndex = Nothing
                    , collectionPageItems      =
                        map (encodeRouteHome . ticketUrl . E.unValue) tickets
                    }
    where
    here = SharerTicketsR shr
    provide :: ActivityPub a => a URIMode -> Handler TypedContent
    provide a = provideHtmlAndAP a $ redirectToPrettyJSON here
    countTickets pid = fmap toOne $
        E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do
            E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
            E.where_ $
                tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
                E.isNothing (tup E.?. TicketUnderProjectId)
            return $ E.count $ tal E.^. TicketAuthorLocalId
        where
        toOne [x] = E.unValue x
        toOne []  = error "toOne = 0"
        toOne _   = error "toOne > 1"
    selectTickets pid off lim =
        E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do
            E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
            E.where_ $
                tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
                E.isNothing (tup E.?. TicketUnderProjectId)
            E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId]
            E.offset $ fromIntegral off
            E.limit $ fromIntegral lim
            return $ tal E.^. TicketAuthorLocalId

getSharerTicketR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketR shr talkhid = do
    (ticket, project, massignee) <- runDB $ do
        (_, _, Entity _ t, tp) <- getSharerTicket shr talkhid
        (,,) t
            <$> bitraverse
                    (\ (Entity _ tpl) -> do
                        j <- getJust $ ticketProjectLocalProject tpl
                        s <- getJust $ projectSharer j
                        return (s, j)
                    )
                    return
                    tp
            <*> (for (ticketAssignee t) $ \ pidAssignee -> do
                    p <- getJust pidAssignee
                    getJust $ personIdent p
                )
    hLocal <- getsYesod siteInstanceHost
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    let ticketAP = AP.Ticket
            { AP.ticketLocal        = Just
                ( hLocal
                , AP.TicketLocal
                    { AP.ticketId =
                        encodeRouteLocal $ SharerTicketR shr talkhid
                    , AP.ticketContext =
                        encodeRouteLocal $
                            case project of
                                Left (s, j) ->
                                    ProjectR (sharerIdent s) (projectIdent j)
                                Right () -> error "No TPR yet!"
                    , AP.ticketReplies =
                        encodeRouteLocal $ SharerTicketDiscussionR shr talkhid
                    , AP.ticketParticipants =
                        encodeRouteLocal $ SharerTicketFollowersR shr talkhid
                    , AP.ticketTeam =
                        encodeRouteLocal $ SharerTicketTeamR shr talkhid
                    , AP.ticketEvents =
                        encodeRouteLocal $ SharerTicketEventsR shr talkhid
                    , AP.ticketDeps =
                        encodeRouteLocal $ SharerTicketDepsR shr talkhid
                    , AP.ticketReverseDeps =
                        encodeRouteLocal $ SharerTicketReverseDepsR shr talkhid
                    }
                )
            , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr
            , AP.ticketPublished    = Just $ ticketCreated ticket
            , AP.ticketUpdated      = Nothing
            , AP.ticketSummary      = TextHtml $ ticketTitle ticket
            , AP.ticketContent      = TextHtml $ ticketDescription ticket
            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
            , AP.ticketAssignedTo   =
                encodeRouteHome . SharerR . sharerIdent <$> massignee
            , AP.ticketIsResolved   = ticketStatus ticket == TSClosed
            }
    provideHtmlAndAP ticketAP $ redirectToPrettyJSON here
    where
    here = SharerTicketR shr talkhid

getSharerTicketDiscussionR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDiscussionR shr talkhid = do
    (locals, remotes) <- runDB $ do
        (_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
        let did = localTicketDiscuss lt
        (,) <$> selectLocals did <*> selectRemotes did
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    encodeHid <- getEncodeKeyHashid
    let localUri' = localUri encodeRouteHome encodeHid
        replies = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ length locals + length remotes
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      =
                map localUri' locals ++ map remoteUri remotes
            }
    provideHtmlAndAP replies $ redirectToPrettyJSON here
    where
    here = SharerTicketDiscussionR shr talkhid
    selectLocals did =
        E.select $ E.from $
            \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do
                E.on $ p E.^. PersonIdent E.==. s E.^. SharerId
                E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId
                E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest
                E.where_ $
                    m E.^. MessageRoot E.==. E.val did E.&&.
                    E.isNothing (m E.^. MessageParent) E.&&.
                    E.isNothing (lm E.^. LocalMessageUnlinkedParent)
                return (s E.^. SharerIdent, lm E.^. LocalMessageId)
    selectRemotes did =
        E.select $ E.from $
            \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do
                E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
                E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId
                E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest
                E.where_ $
                    m E.^. MessageRoot E.==. E.val did E.&&.
                    E.isNothing (m E.^. MessageParent) E.&&.
                    E.isNothing (rm E.^. RemoteMessageLostParent)
                return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
    localUri encR encH (E.Value shrAuthor, E.Value lmid) =
        encR $ MessageR shrAuthor (encH lmid)
    remoteUri (E.Value h, E.Value lu) = ObjURI h lu

getSharerTicketDeps
    :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDeps forward shr talkhid = do
    tdids <- runDB $ do
        (_, _, Entity tid _, _) <- getSharerTicket shr talkhid
        let (from, to) =
                if forward
                    then (TicketDependencyParent, TicketDependencyChild)
                    else (TicketDependencyChild, TicketDependencyParent)
        E.select $ E.from $ \ (td `E.InnerJoin` t) -> do
            E.on $ td E.^. to E.==. t E.^. TicketId
            E.where_ $ td E.^. from E.==. E.val tid
            return $ td E.^. TicketDependencyId
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
    encodeHid <- getEncodeKeyHashid
    let deps = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just $ length tdids
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      =
                map (encodeRouteHome . TicketDepR . encodeHid . E.unValue)
                    tdids
            }
    provideHtmlAndAP deps $ redirectToPrettyJSON here
    where
    here =
        let route =
                if forward then SharerTicketDepsR else SharerTicketReverseDepsR
        in  route shr talkhid

getSharerTicketDepsR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDepsR = getSharerTicketDeps True

getSharerTicketReverseDepsR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketReverseDepsR = getSharerTicketDeps False

getSharerTicketFollowersR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
    where
    here = SharerTicketFollowersR shr talkhid
    getFsid = do
        (_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
        return $ localTicketFollowers lt

getSharerTicketTeamR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketTeamR shr talkhid = do
    _ <- runDB $ getSharerTicket shr talkhid
    encodeRouteLocal <- getEncodeRouteLocal
    let team = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeUnordered
            , collectionTotalItems = Just 0
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      = [] :: [Text]
            }
    provideHtmlAndAP team $ redirectToPrettyJSON here
    where
    here = SharerTicketTeamR shr talkhid

getSharerTicketEventsR
    :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketEventsR shr talkhid = do
    _ <- runDB $ getSharerTicket shr talkhid
    encodeRouteLocal <- getEncodeRouteLocal
    let team = Collection
            { collectionId         = encodeRouteLocal here
            , collectionType       = CollectionTypeOrdered
            , collectionTotalItems = Just 0
            , collectionCurrent    = Nothing
            , collectionFirst      = Nothing
            , collectionLast       = Nothing
            , collectionItems      = [] :: [Text]
            }
    provideHtmlAndAP team $ redirectToPrettyJSON here
    where
    here = SharerTicketEventsR shr talkhid