mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-14 21:56:20 +09:00
990 lines
40 KiB
Haskell
990 lines
40 KiB
Haskell
{- 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 Control.Applicative (liftA2)
|
||
import Control.Monad
|
||
import Control.Monad.IO.Class (liftIO)
|
||
import Control.Monad.Logger (logWarn)
|
||
import Control.Monad.Trans.Except
|
||
import Data.Bifunctor
|
||
import Data.Bool (bool)
|
||
import Data.Default.Class (def)
|
||
import Data.Foldable (traverse_)
|
||
import Data.Maybe (fromMaybe)
|
||
import Data.Monoid ((<>))
|
||
import Data.Text (Text)
|
||
import Data.Time.Calendar (Day (..))
|
||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||
import Data.Time.Format (formatTime, defaultTimeLocale)
|
||
import Data.Traversable (for)
|
||
import Database.Persist
|
||
import Network.HTTP.Types (StdMethod (DELETE, POST))
|
||
import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
|
||
import Text.Blaze.Html.Renderer.Text
|
||
import Text.HTML.SanitizeXSS
|
||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||
import Yesod.Core
|
||
import Yesod.Core.Handler
|
||
import Yesod.Form.Functions (runFormGet, runFormPost)
|
||
import Yesod.Form.Types (FormResult (..))
|
||
import Yesod.Persist.Core (runDB, get404, getBy404)
|
||
|
||
import qualified Data.Text as T (filter, intercalate, pack)
|
||
import qualified Data.Text.Lazy as TL
|
||
import qualified Database.Esqueleto as E
|
||
|
||
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
|
||
|
||
import Data.Aeson.Encode.Pretty.ToEncoding
|
||
import Network.FedURI
|
||
import Web.ActivityPub hiding (Ticket (..))
|
||
import Yesod.ActivityPub
|
||
import Yesod.Auth.Unverified
|
||
import Yesod.FedURI
|
||
import Yesod.Hashids
|
||
|
||
import qualified Web.ActivityPub as AP
|
||
|
||
import Data.Either.Local
|
||
import Data.Maybe.Local (partitionMaybePairs)
|
||
import Database.Persist.Local
|
||
import Yesod.Persist.Local
|
||
|
||
import Vervis.API
|
||
import Vervis.Federation
|
||
import Vervis.Form.Ticket
|
||
import Vervis.Foundation
|
||
import Vervis.Handler.Discussion
|
||
import Vervis.GraphProxy (ticketDepGraph)
|
||
import Data.MediaType
|
||
import Vervis.Model
|
||
import Vervis.Model.Ident
|
||
import Vervis.Model.Ticket
|
||
import Vervis.Model.Workflow
|
||
import Yesod.RenderSource
|
||
import Vervis.Settings
|
||
import Vervis.Style
|
||
import Vervis.Ticket
|
||
import Vervis.TicketFilter (filterTickets)
|
||
import Vervis.Time (showDate)
|
||
import Vervis.Widget (buttonW)
|
||
import Vervis.Widget.Discussion (discussionW)
|
||
import Vervis.Widget.Sharer
|
||
import Vervis.Widget.Ticket
|
||
|
||
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getTicketsR shr prj = do
|
||
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
|
||
let tf =
|
||
case filtResult of
|
||
FormSuccess filt -> filt
|
||
FormMissing -> def
|
||
FormFailure l ->
|
||
error $ "Ticket filter form failed: " ++ show l
|
||
rows <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
getTicketSummaries
|
||
(filterTickets tf)
|
||
(Just $ \ t -> [E.asc $ t E.^. TicketNumber])
|
||
jid
|
||
defaultLayout $(widgetFile "ticket/list")
|
||
|
||
postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||
postTicketsR shr prj = do
|
||
wid <- runDB $ do
|
||
sid <- getKeyBy404 $ UniqueSharer shr
|
||
j <- getValBy404 $ UniqueProject prj sid
|
||
return $ projectWorkflow j
|
||
((result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||
enum <- runExceptT $ do
|
||
NewTicket title desc tparams eparams <-
|
||
case result of
|
||
FormMissing -> throwE "Field(s) missing."
|
||
FormFailure _l ->
|
||
throwE "Ticket submission failed, see errors below."
|
||
FormSuccess nt -> return nt
|
||
unless (null tparams && null eparams) $
|
||
throwE "Custom param support currently disabled"
|
||
{-
|
||
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
|
||
-}
|
||
encodeRouteLocal <- getEncodeRouteLocal
|
||
encodeRouteHome <- getEncodeRouteHome
|
||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||
shrAuthor <- do
|
||
Entity _ p <- requireVerifiedAuth
|
||
lift $ runDB $ sharerIdent <$> getJust (personIdent p)
|
||
summary <-
|
||
TextHtml . TL.toStrict . renderHtml <$>
|
||
withUrlRenderer
|
||
[hamlet|
|
||
<p>
|
||
<a href=@{SharerR shrAuthor}>
|
||
#{shr2text shrAuthor}
|
||
\ offered a ticket to project #
|
||
<a href=@{ProjectR shr prj}>
|
||
./s/#{shr2text shr}/p/#{prj2text prj}
|
||
: #{preEscapedToHtml title}.
|
||
|]
|
||
let recipsA = [ProjectR shr prj]
|
||
recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
|
||
ticket = AP.Ticket
|
||
{ AP.ticketLocal = Nothing
|
||
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
|
||
, AP.ticketPublished = Nothing
|
||
, AP.ticketUpdated = Nothing
|
||
, AP.ticketName = Nothing
|
||
, AP.ticketSummary = TextHtml title
|
||
, AP.ticketContent = TextHtml descHtml
|
||
, AP.ticketSource = TextPandocMarkdown desc
|
||
, AP.ticketAssignedTo = Nothing
|
||
, AP.ticketIsResolved = False
|
||
, AP.ticketDependsOn = []
|
||
, AP.ticketDependedBy = []
|
||
}
|
||
offer = Offer
|
||
{ offerObject = ticket
|
||
, offerTarget = encodeRouteHome $ ProjectR shr prj
|
||
}
|
||
audience = Audience
|
||
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC
|
||
, audienceBto = []
|
||
, audienceCc = []
|
||
, audienceBcc = []
|
||
, audienceGeneral = []
|
||
, audienceNonActors = map encodeRouteHome recipsC
|
||
}
|
||
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
|
||
ExceptT $ runDB $ do
|
||
mtal <- getValBy $ UniqueTicketAuthorLocalOffer obiid
|
||
case mtal of
|
||
Nothing ->
|
||
return $
|
||
Left
|
||
"Offer processed successfully but no ticket \
|
||
\created"
|
||
Just tal ->
|
||
Right . ticketNumber <$>
|
||
getJust (ticketAuthorLocalTicket tal)
|
||
case enum of
|
||
Left e -> do
|
||
setMessage $ toHtml e
|
||
defaultLayout $(widgetFile "ticket/new")
|
||
Right num -> do
|
||
setMessage "Ticket created."
|
||
redirect $ TicketR shr prj num
|
||
|
||
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getTicketTreeR shr prj = do
|
||
(summaries, deps) <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
liftA2 (,)
|
||
(getTicketSummaries Nothing Nothing jid)
|
||
(getTicketDepEdges jid)
|
||
defaultLayout $ ticketTreeDW shr prj summaries deps
|
||
|
||
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getTicketNewR shr prj = do
|
||
wid <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity _ j <- getBy404 $ UniqueProject prj sid
|
||
return $ projectWorkflow j
|
||
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||
defaultLayout $(widgetFile "ticket/new")
|
||
|
||
getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||
getTicketR shar proj num = do
|
||
mpid <- maybeAuthId
|
||
( wshr, wfl,
|
||
author, massignee, mcloser, ticket, tparams, eparams, deps, rdeps) <-
|
||
runDB $ do
|
||
(jid, wshr, wid, wfl) <- do
|
||
Entity s sharer <- getBy404 $ UniqueSharer shar
|
||
Entity p project <- getBy404 $ UniqueProject proj s
|
||
w <- get404 $ projectWorkflow project
|
||
wsharer <-
|
||
if workflowSharer w == s
|
||
then return sharer
|
||
else get404 $ workflowSharer w
|
||
return
|
||
( p
|
||
, sharerIdent wsharer
|
||
, projectWorkflow project
|
||
, workflowIdent w
|
||
)
|
||
Entity tid ticket <- getBy404 $ UniqueTicket jid num
|
||
author <-
|
||
requireEitherAlt
|
||
(do mtal <- getValBy $ UniqueTicketAuthorLocal tid
|
||
for mtal $ \ tal -> do
|
||
p <- getJust $ ticketAuthorLocalAuthor tal
|
||
getJust $ personIdent p
|
||
)
|
||
(do mtar <- getValBy $ UniqueTicketAuthorRemote tid
|
||
for mtar $ \ tar -> do
|
||
ra <- getJust $ ticketAuthorRemoteAuthor tar
|
||
i <- getJust $ remoteActorInstance ra
|
||
return (i, ra)
|
||
)
|
||
"Ticket doesn't have author"
|
||
"Ticket has both local and remote author"
|
||
massignee <- for (ticketAssignee ticket) $ \ apid -> do
|
||
person <- get404 apid
|
||
sharer <- get404 $ personIdent person
|
||
return (sharer, fromMaybe False $ (== apid) <$> mpid)
|
||
mcloser <-
|
||
case ticketStatus ticket of
|
||
TSClosed ->
|
||
case ticketCloser ticket of
|
||
Just pidCloser -> Just <$> do
|
||
person <- getJust pidCloser
|
||
getJust $ personIdent person
|
||
Nothing -> error "Closer not set for closed ticket"
|
||
_ ->
|
||
case ticketCloser ticket of
|
||
Just _ -> error "Closer set for open ticket"
|
||
Nothing -> return Nothing
|
||
tparams <- getTicketTextParams tid wid
|
||
eparams <- getTicketEnumParams tid wid
|
||
deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
|
||
E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
|
||
E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
|
||
return t
|
||
rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
|
||
E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
|
||
E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
|
||
return t
|
||
return
|
||
( wshr, wfl
|
||
, author, massignee, mcloser, ticket, tparams, eparams
|
||
, deps, rdeps
|
||
)
|
||
encodeHid <- getEncodeKeyHashid
|
||
let desc :: Widget
|
||
desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
|
||
discuss =
|
||
discussionW
|
||
(return $ ticketDiscuss ticket)
|
||
(TicketTopReplyR shar proj num)
|
||
(TicketReplyR shar proj num . encodeHid)
|
||
cRelevant <- newIdent
|
||
cIrrelevant <- newIdent
|
||
let relevant filt =
|
||
bool cIrrelevant cRelevant $
|
||
case ticketStatus ticket of
|
||
TSNew -> wffNew filt
|
||
TSTodo -> wffTodo filt
|
||
TSClosed -> wffClosed filt
|
||
hLocal <- getsYesod siteInstanceHost
|
||
encodeRouteLocal <- getEncodeRouteLocal
|
||
encodeRouteHome <- getEncodeRouteHome
|
||
let siblingUri =
|
||
encodeRouteHome . TicketR shar proj . ticketNumber . entityVal
|
||
host =
|
||
case author of
|
||
Left _ -> hLocal
|
||
Right (i, _) -> instanceHost i
|
||
ticketAP = AP.Ticket
|
||
{ AP.ticketLocal = Just
|
||
( hLocal
|
||
, AP.TicketLocal
|
||
{ AP.ticketId =
|
||
encodeRouteLocal $ TicketR shar proj num
|
||
, AP.ticketContext =
|
||
encodeRouteLocal $ ProjectR shar proj
|
||
, AP.ticketReplies =
|
||
encodeRouteLocal $ TicketDiscussionR shar proj num
|
||
, AP.ticketParticipants =
|
||
encodeRouteLocal $ TicketParticipantsR shar proj num
|
||
, AP.ticketTeam =
|
||
encodeRouteLocal $ TicketTeamR shar proj num
|
||
, AP.ticketEvents =
|
||
encodeRouteLocal $ TicketEventsR shar proj num
|
||
}
|
||
)
|
||
|
||
, AP.ticketAttributedTo =
|
||
case author of
|
||
Left sharer ->
|
||
encodeRouteLocal $ SharerR $ sharerIdent sharer
|
||
Right (_inztance, actor) ->
|
||
remoteActorIdent actor
|
||
, 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
|
||
, AP.ticketDependsOn = map siblingUri deps
|
||
, AP.ticketDependedBy = map siblingUri rdeps
|
||
}
|
||
provideHtmlAndAP' host 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 =. Just pid
|
||
]
|
||
return True
|
||
setMessage $
|
||
if succ
|
||
then "Ticket closed."
|
||
else "Ticket is already closed."
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketOpenR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketOpenR shr prj num = do
|
||
pid <- requireAuthId
|
||
now <- liftIO getCurrentTime
|
||
succ <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ticketStatus ticket of
|
||
TSClosed -> do
|
||
update tid
|
||
[ TicketStatus =. TSTodo
|
||
, TicketCloser =. Nothing
|
||
]
|
||
return True
|
||
_ -> return False
|
||
setMessage $
|
||
if succ
|
||
then "Ticket reopened"
|
||
else "Ticket is already open."
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketClaimR shr prj num = do
|
||
pid <- requireAuthId
|
||
mmsg <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case (ticketStatus ticket, ticketAssignee ticket) of
|
||
(TSNew, _) ->
|
||
return $
|
||
Just "The ticket isn’t accepted yet. Can’t claim it."
|
||
(TSClosed, _) ->
|
||
return $
|
||
Just "The ticket is closed. Can’t claim closed tickets."
|
||
(TSTodo, Just _) ->
|
||
return $
|
||
Just "The ticket is already assigned to someone."
|
||
(TSTodo, Nothing) -> do
|
||
update tid [TicketAssignee =. Just pid]
|
||
return Nothing
|
||
setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketUnclaimR shr prj num = do
|
||
pid <- requireAuthId
|
||
mmsg <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
|
||
(Nothing, _) ->
|
||
return $ Just "The ticket is already unassigned."
|
||
(Just False, _) ->
|
||
return $ Just "The ticket is assigned to someone else."
|
||
(Just True, TSNew) -> do
|
||
$logWarn "Found a new claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket isn’t accepted yet. Can’t unclaim it."
|
||
(Just True, TSClosed) -> do
|
||
$logWarn "Found a closed claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket is closed. Can’t unclaim closed tickets."
|
||
(Just True, TSTodo) -> do
|
||
update tid [TicketAssignee =. Nothing]
|
||
return Nothing
|
||
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
|
||
redirect $ TicketR shr prj num
|
||
|
||
getTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketAssignR shr prj num = do
|
||
vpid <- requireAuthId
|
||
(jid, Entity tid ticket) <- runDB $ do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity j _ <- getBy404 $ UniqueProject prj s
|
||
et <- getBy404 $ UniqueTicket j num
|
||
return (j, et)
|
||
let msg t = do
|
||
setMessage t
|
||
redirect $ TicketR shr prj num
|
||
case (ticketStatus ticket, ticketAssignee ticket) of
|
||
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
|
||
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
|
||
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
|
||
(TSTodo, Nothing) -> do
|
||
((_result, widget), enctype) <-
|
||
runFormPost $ assignTicketForm vpid jid
|
||
defaultLayout $(widgetFile "ticket/assign")
|
||
|
||
postTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketAssignR shr prj num = do
|
||
vpid <- requireAuthId
|
||
(jid, Entity tid ticket) <- runDB $ do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity j _ <- getBy404 $ UniqueProject prj s
|
||
et <- getBy404 $ UniqueTicket j num
|
||
return (j, et)
|
||
let msg t = do
|
||
setMessage t
|
||
redirect $ TicketR shr prj num
|
||
case (ticketStatus ticket, ticketAssignee ticket) of
|
||
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
|
||
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
|
||
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
|
||
(TSTodo, Nothing) -> do
|
||
((result, widget), enctype) <-
|
||
runFormPost $ assignTicketForm vpid jid
|
||
case result of
|
||
FormSuccess pid -> do
|
||
sharer <- runDB $ do
|
||
update tid [TicketAssignee =. Just pid]
|
||
person <- getJust pid
|
||
getJust $ personIdent person
|
||
let si = sharerIdent sharer
|
||
msg $ toHtml $
|
||
"The ticket is now assigned to " <> shr2text si <> "."
|
||
FormMissing -> do
|
||
setMessage "Field(s) missing."
|
||
defaultLayout $(widgetFile "ticket/assign")
|
||
FormFailure _l -> do
|
||
setMessage "Ticket assignment failed, see errors below."
|
||
defaultLayout $(widgetFile "ticket/assign")
|
||
|
||
postTicketUnassignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketUnassignR shr prj num = do
|
||
pid <- requireAuthId
|
||
mmsg <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
|
||
(Nothing, _) ->
|
||
return $ Just "The ticket is already unassigned."
|
||
(Just True, _) ->
|
||
return $ Just "The ticket is assigned to you, unclaim instead."
|
||
(Just False, TSNew) -> do
|
||
$logWarn "Found a new claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket isn’t accepted yet. Can’t unclaim it."
|
||
(Just False, TSClosed) -> do
|
||
$logWarn "Found a closed claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket is closed. Can’t unclaim closed tickets."
|
||
(Just False, TSTodo) -> do
|
||
update tid [TicketAssignee =. Nothing]
|
||
return Nothing
|
||
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
|
||
redirect $ TicketR shr prj num
|
||
|
||
-- | The logged-in user gets a list of the ticket claim requests they have
|
||
-- opened, in any project.
|
||
getClaimRequestsPersonR :: Handler Html
|
||
getClaimRequestsPersonR = do
|
||
pid <- requireAuthId
|
||
rqs <- runDB $ E.select $ E.from $
|
||
\ (tcr `E.InnerJoin` ticket `E.InnerJoin` project `E.InnerJoin` sharer) -> do
|
||
E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId
|
||
E.on $ ticket E.^. TicketProject E.==. project E.^. ProjectId
|
||
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
|
||
E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid
|
||
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
|
||
return
|
||
( sharer E.^. SharerIdent
|
||
, project E.^. ProjectIdent
|
||
, ticket E.^. TicketNumber
|
||
, ticket E.^. TicketTitle
|
||
, tcr E.^. TicketClaimRequestCreated
|
||
)
|
||
defaultLayout $(widgetFile "person/claim-requests")
|
||
|
||
-- | Get a list of ticket claim requests for a given project.
|
||
getClaimRequestsProjectR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getClaimRequestsProjectR shr prj = do
|
||
rqs <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
E.select $ E.from $
|
||
\ ( tcr `E.InnerJoin`
|
||
ticket `E.InnerJoin`
|
||
person `E.InnerJoin`
|
||
sharer
|
||
) -> do
|
||
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
|
||
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
|
||
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
|
||
E.where_ $ ticket E.^. TicketProject E.==. E.val jid
|
||
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
|
||
return
|
||
( sharer
|
||
, ticket E.^. TicketNumber
|
||
, ticket E.^. TicketTitle
|
||
, tcr E.^. TicketClaimRequestCreated
|
||
)
|
||
defaultLayout $(widgetFile "project/claim-request/list")
|
||
|
||
-- | Get a list of ticket claim requests for a given ticket.
|
||
getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getClaimRequestsTicketR shr prj num = do
|
||
rqs <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
Entity tid _ <- getBy404 $ UniqueTicket jid num
|
||
E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
|
||
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
|
||
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
|
||
E.where_ $ tcr E.^. TicketClaimRequestTicket E.==. E.val tid
|
||
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
|
||
return (sharer, tcr)
|
||
defaultLayout $(widgetFile "ticket/claim-request/list")
|
||
|
||
getClaimRequestNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getClaimRequestNewR shr prj num = do
|
||
((_result, widget), etype) <- runFormPost claimRequestForm
|
||
defaultLayout $(widgetFile "ticket/claim-request/new")
|
||
|
||
postClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postClaimRequestsTicketR shr prj num = do
|
||
((result, widget), etype) <- runFormPost claimRequestForm
|
||
case result of
|
||
FormSuccess msg -> do
|
||
now <- liftIO getCurrentTime
|
||
pid <- requireAuthId
|
||
runDB $ do
|
||
tid <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity j _ <- getBy404 $ UniqueProject prj s
|
||
Entity t _ <- getBy404 $ UniqueTicket j num
|
||
return t
|
||
let cr = TicketClaimRequest
|
||
{ ticketClaimRequestPerson = pid
|
||
, ticketClaimRequestTicket = tid
|
||
, ticketClaimRequestMessage = msg
|
||
, ticketClaimRequestCreated = now
|
||
}
|
||
insert_ cr
|
||
setMessage "Ticket claim request opened."
|
||
redirect $ TicketR shr prj num
|
||
FormMissing -> do
|
||
setMessage "Field(s) missing."
|
||
defaultLayout $(widgetFile "ticket/claim-request/new")
|
||
FormFailure _l -> do
|
||
setMessage "Submission failed, see errors below."
|
||
defaultLayout $(widgetFile "ticket/claim-request/new")
|
||
|
||
selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId
|
||
selectDiscussionId shar proj tnum = do
|
||
Entity sid _sharer <- getBy404 $ UniqueSharer shar
|
||
Entity pid _project <- getBy404 $ UniqueProject proj sid
|
||
Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum
|
||
return $ ticketDiscuss ticket
|
||
|
||
getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketDiscussionR shar proj num = do
|
||
encodeHid <- getEncodeKeyHashid
|
||
getDiscussion
|
||
(TicketReplyR shar proj num . encodeHid)
|
||
(TicketTopReplyR shar proj num)
|
||
(selectDiscussionId shar proj num)
|
||
|
||
postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketDiscussionR shr prj num = do
|
||
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||
postTopReply
|
||
hLocal
|
||
[ProjectR shr prj]
|
||
[ ProjectFollowersR shr prj
|
||
, TicketParticipantsR shr prj num
|
||
, TicketTeamR shr prj num
|
||
]
|
||
(TicketR shr prj num)
|
||
(TicketDiscussionR shr prj num)
|
||
(const $ TicketR shr prj num)
|
||
|
||
getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
|
||
getMessageR shr hid = do
|
||
lmid <- decodeKeyHashid404 hid
|
||
getDiscussionMessage shr lmid
|
||
|
||
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
|
||
postTicketMessageR shr prj num mkhid = do
|
||
encodeHid <- getEncodeKeyHashid
|
||
mid <- decodeKeyHashid404 mkhid
|
||
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||
postReply
|
||
hLocal
|
||
[ProjectR shr prj]
|
||
[ ProjectFollowersR shr prj
|
||
, TicketParticipantsR shr prj num
|
||
, TicketTeamR shr prj num
|
||
]
|
||
(TicketR shr prj num)
|
||
(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
|
||
fmap (map toRow) $ E.select $ E.from $
|
||
\ ( td
|
||
`E.InnerJoin` t
|
||
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
|
||
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` i)
|
||
) -> do
|
||
E.on $ ra E.?. RemoteActorInstance E.==. i E.?. InstanceId
|
||
E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
|
||
E.on $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket
|
||
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
|
||
E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
|
||
E.on $ E.just (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket
|
||
E.on $ td E.^. to' E.==. t E.^. TicketId
|
||
E.where_ $ td E.^. from' E.==. E.val tid
|
||
E.orderBy [E.asc $ t E.^. TicketNumber]
|
||
return
|
||
( t E.^. TicketNumber
|
||
, s
|
||
, i
|
||
, ra
|
||
, t E.^. TicketTitle
|
||
, t E.^. TicketStatus
|
||
)
|
||
defaultLayout $(widgetFile "ticket/dep/list")
|
||
where
|
||
toRow (E.Value number, ms, mi, mra, E.Value title, E.Value status) =
|
||
( number
|
||
, case (ms, mi, mra) of
|
||
(Just s, Nothing, Nothing) ->
|
||
Left $ entityVal s
|
||
(Nothing, Just i, Just ra) ->
|
||
Right (entityVal i, entityVal ra)
|
||
_ -> error "Ticket author DB invalid state"
|
||
, title
|
||
, status
|
||
)
|
||
|
||
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 = getFollowersCollection here getFsid
|
||
where
|
||
here = TicketParticipantsR shr prj num
|
||
getFsid = do
|
||
sid <- getKeyBy404 $ UniqueSharer shr
|
||
jid <- getKeyBy404 $ UniqueProject prj sid
|
||
t <- getValBy404 $ UniqueTicket jid num
|
||
return $ ticketFollowers t
|
||
|
||
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||
getTicketTeamR shr prj num = do
|
||
memberShrs <- runDB $ do
|
||
sid <- getKeyBy404 $ UniqueSharer shr
|
||
_jid <- getKeyBy404 $ UniqueProject prj sid
|
||
_tid <- getKeyBy404 $ UniqueTicket _jid num
|
||
id_ <-
|
||
requireEitherAlt
|
||
(getKeyBy $ UniquePersonIdent sid)
|
||
(getKeyBy $ UniqueGroup sid)
|
||
"Found sharer that is neither person nor group"
|
||
"Found sharer that is both person and group"
|
||
case id_ of
|
||
Left pid -> return [shr]
|
||
Right gid -> do
|
||
pids <-
|
||
map (groupMemberPerson . entityVal) <$>
|
||
selectList [GroupMemberGroup ==. gid] []
|
||
sids <-
|
||
map (personIdent . entityVal) <$>
|
||
selectList [PersonId <-. pids] []
|
||
map (sharerIdent . entityVal) <$>
|
||
selectList [SharerId <-. sids] []
|
||
|
||
let here = TicketTeamR shr prj num
|
||
|
||
encodeRouteLocal <- getEncodeRouteLocal
|
||
encodeRouteHome <- getEncodeRouteHome
|
||
let team = Collection
|
||
{ collectionId = encodeRouteLocal here
|
||
, collectionType = CollectionTypeUnordered
|
||
, collectionTotalItems = Just $ length memberShrs
|
||
, collectionCurrent = Nothing
|
||
, collectionFirst = Nothing
|
||
, collectionLast = Nothing
|
||
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
|
||
}
|
||
provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
|
||
|
||
getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||
getTicketEventsR shr prj num = error "TODO not implemented"
|