mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-10 01:16:46 +09:00
763 lines
30 KiB
Haskell
763 lines
30 KiB
Haskell
{- This file is part of Vervis.
|
||
-
|
||
- Written in 2016, 2018 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
|
||
, getTicketMessageR
|
||
, postTicketMessageR
|
||
, getTicketTopReplyR
|
||
, getTicketReplyR
|
||
, getTicketDepsR
|
||
, postTicketDepsR
|
||
, getTicketDepNewR
|
||
, postTicketDepR
|
||
, deleteTicketDepR
|
||
, getTicketReverseDepsR
|
||
)
|
||
where
|
||
|
||
import Prelude
|
||
|
||
import Control.Applicative (liftA2)
|
||
import Control.Monad.IO.Class (liftIO)
|
||
import Control.Monad.Logger (logWarn)
|
||
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.Esqueleto hiding ((=.), (+=.), update, delete)
|
||
import Database.Persist hiding ((==.))
|
||
import Network.HTTP.Types (StdMethod (DELETE, POST))
|
||
import Text.Blaze.Html (Html, toHtml)
|
||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||
import Yesod.Core (defaultLayout)
|
||
import Yesod.Core.Handler hiding (getMessage)
|
||
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 Database.Esqueleto as E ((==.))
|
||
|
||
import Data.Maybe.Local (partitionMaybePairs)
|
||
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
|
||
import Vervis.Form.Ticket
|
||
import Vervis.Foundation
|
||
import Vervis.Handler.Discussion
|
||
import Vervis.GraphProxy (ticketDepGraph)
|
||
import Vervis.MediaType (MediaType (Markdown))
|
||
import Vervis.Model
|
||
import Vervis.Model.Ident
|
||
import Vervis.Model.Ticket
|
||
import Vervis.Model.Workflow
|
||
import Vervis.Render (renderSourceT)
|
||
import Vervis.Settings (widgetFile)
|
||
import Vervis.Style
|
||
import Vervis.Ticket
|
||
import Vervis.TicketFilter (filterTickets)
|
||
import Vervis.Time (showDate)
|
||
import Vervis.Widget (buttonW)
|
||
import Vervis.Widget.Discussion (discussionW)
|
||
import Vervis.Widget.Sharer (personLinkW)
|
||
import Vervis.Widget.Ticket
|
||
|
||
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getTicketsR shr prj = do
|
||
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
|
||
let tf =
|
||
case filtResult of
|
||
FormSuccess filt -> filt
|
||
FormMissing -> def
|
||
FormFailure l ->
|
||
error $ "Ticket filter form failed: " ++ show l
|
||
rows <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
getTicketSummaries
|
||
(filterTickets tf)
|
||
(Just $ \ t -> [asc $ t ^. TicketNumber])
|
||
jid
|
||
defaultLayout $(widgetFile "ticket/list")
|
||
|
||
postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||
postTicketsR shar proj = do
|
||
Entity pid project <- runDB $ do
|
||
Entity sid _sharer <- getBy404 $ UniqueSharer shar
|
||
getBy404 $ UniqueProject proj sid
|
||
((result, widget), enctype) <-
|
||
runFormPost $ newTicketForm $ projectWorkflow project
|
||
case result of
|
||
FormSuccess nt -> do
|
||
author <- requireAuthId
|
||
now <- liftIO getCurrentTime
|
||
tnum <- runDB $ do
|
||
update pid [ProjectNextTicket +=. 1]
|
||
let discussion = Discussion
|
||
{ discussionNextMessage = 1
|
||
}
|
||
did <- insert discussion
|
||
let ticket = Ticket
|
||
{ ticketProject = pid
|
||
, ticketNumber = projectNextTicket project
|
||
, ticketCreated = now
|
||
, ticketCreator = author
|
||
, ticketTitle = ntTitle nt
|
||
, ticketDesc = ntDesc nt
|
||
, ticketAssignee = Nothing
|
||
, ticketStatus = TSNew
|
||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||
, ticketCloser = author
|
||
, ticketDiscuss = did
|
||
}
|
||
tid <- insert ticket
|
||
let mktparam (fid, v) = TicketParamText
|
||
{ ticketParamTextTicket = tid
|
||
, ticketParamTextField = fid
|
||
, ticketParamTextValue = v
|
||
}
|
||
insertMany_ $ map mktparam $ ntTParams nt
|
||
let mkeparam (fid, v) = TicketParamEnum
|
||
{ ticketParamEnumTicket = tid
|
||
, ticketParamEnumField = fid
|
||
, ticketParamEnumValue = v
|
||
}
|
||
insertMany_ $ map mkeparam $ ntEParams nt
|
||
return $ ticketNumber ticket
|
||
setMessage "Ticket created."
|
||
redirect $ TicketR shar proj tnum
|
||
FormMissing -> do
|
||
setMessage "Field(s) missing."
|
||
defaultLayout $(widgetFile "ticket/new")
|
||
FormFailure _l -> do
|
||
setMessage "Ticket creation failed, see errors below."
|
||
defaultLayout $(widgetFile "ticket/new")
|
||
|
||
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getTicketTreeR shr prj = do
|
||
(summaries, deps) <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
liftA2 (,)
|
||
(getTicketSummaries Nothing Nothing jid)
|
||
(getTicketDepEdges jid)
|
||
defaultLayout $ ticketTreeDW shr prj summaries deps
|
||
|
||
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
|
||
getTicketNewR shar proj = do
|
||
wid <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shar
|
||
Entity _ j <- getBy404 $ UniqueProject proj sid
|
||
return $ projectWorkflow j
|
||
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||
defaultLayout $(widgetFile "ticket/new")
|
||
|
||
getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketR shar proj num = do
|
||
mpid <- maybeAuthId
|
||
( wshr, wfl,
|
||
author, massignee, closer, ticket, tparams, eparams, deps, rdeps) <-
|
||
runDB $ do
|
||
(jid, wshr, wid, wfl) <- do
|
||
Entity s sharer <- getBy404 $ UniqueSharer shar
|
||
Entity p project <- getBy404 $ UniqueProject proj s
|
||
w <- get404 $ projectWorkflow project
|
||
wsharer <-
|
||
if workflowSharer w == s
|
||
then return sharer
|
||
else get404 $ workflowSharer w
|
||
return
|
||
( p
|
||
, sharerIdent wsharer
|
||
, projectWorkflow project
|
||
, workflowIdent w
|
||
)
|
||
Entity tid ticket <- getBy404 $ UniqueTicket jid num
|
||
author <- do
|
||
person <- get404 $ ticketCreator ticket
|
||
get404 $ personIdent person
|
||
massignee <- for (ticketAssignee ticket) $ \ apid -> do
|
||
person <- get404 apid
|
||
sharer <- get404 $ personIdent person
|
||
return (sharer, fromMaybe False $ (== apid) <$> mpid)
|
||
closer <-
|
||
case ticketStatus ticket of
|
||
TSClosed -> do
|
||
person <- get404 $ ticketCloser ticket
|
||
get404 $ personIdent person
|
||
_ -> return author
|
||
tparams <- getTicketTextParams tid wid
|
||
eparams <- getTicketEnumParams tid wid
|
||
deps <- select $ from $ \ (dep `InnerJoin` t) -> do
|
||
on $ dep ^. TicketDependencyChild ==. t ^. TicketId
|
||
where_ $ dep ^. TicketDependencyParent ==. val tid
|
||
return t
|
||
rdeps <- select $ from $ \ (dep `InnerJoin` t) -> do
|
||
on $ dep ^. TicketDependencyParent ==. t ^. TicketId
|
||
where_ $ dep ^. TicketDependencyChild ==. val tid
|
||
return t
|
||
return
|
||
( wshr, wfl
|
||
, author, massignee, closer, ticket, tparams, eparams
|
||
, deps, rdeps
|
||
)
|
||
let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket
|
||
discuss =
|
||
discussionW
|
||
(return $ ticketDiscuss ticket)
|
||
(TicketTopReplyR shar proj num)
|
||
(TicketReplyR shar proj num)
|
||
cRelevant <- newIdent
|
||
cIrrelevant <- newIdent
|
||
let relevant filt =
|
||
bool cIrrelevant cRelevant $
|
||
case ticketStatus ticket of
|
||
TSNew -> wffNew filt
|
||
TSTodo -> wffTodo filt
|
||
TSClosed -> wffClosed filt
|
||
defaultLayout $(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
|
||
runDB $ do
|
||
replace tid ticket'
|
||
let (tdel, tins, tupd) = partitionMaybePairs tparams
|
||
deleteWhere [TicketParamTextId <-. tdel]
|
||
let mktparam (fid, v) = TicketParamText
|
||
{ ticketParamTextTicket = tid
|
||
, ticketParamTextField = fid
|
||
, ticketParamTextValue = v
|
||
}
|
||
insertMany_ $ map mktparam tins
|
||
traverse_
|
||
(\ (aid, (_fid, v)) ->
|
||
update aid [TicketParamTextValue =. v]
|
||
)
|
||
tupd
|
||
let (edel, eins, eupd) = partitionMaybePairs eparams
|
||
deleteWhere [TicketParamEnumId <-. edel]
|
||
let mkeparam (fid, v) = TicketParamEnum
|
||
{ ticketParamEnumTicket = tid
|
||
, ticketParamEnumField = fid
|
||
, ticketParamEnumValue = v
|
||
}
|
||
insertMany_ $ map mkeparam eins
|
||
traverse_
|
||
(\ (aid, (_fid, v)) ->
|
||
update aid [TicketParamEnumValue =. v]
|
||
)
|
||
eupd
|
||
setMessage "Ticket updated."
|
||
redirect $ TicketR shar proj num
|
||
FormMissing -> do
|
||
setMessage "Field(s) missing."
|
||
defaultLayout $(widgetFile "ticket/edit")
|
||
FormFailure _l -> do
|
||
setMessage "Ticket update failed, see errors below."
|
||
defaultLayout $(widgetFile "ticket/edit")
|
||
|
||
deleteTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
deleteTicketR shar proj num =
|
||
--TODO: I can easily implement this, but should it even be possible to
|
||
--delete tickets?
|
||
error "Not implemented"
|
||
|
||
postTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketR shar proj num = do
|
||
mmethod <- lookupPostParam "_method"
|
||
case mmethod of
|
||
Just "PUT" -> putTicketR shar proj num
|
||
Just "DELETE" -> deleteTicketR shar proj num
|
||
_ -> notFound
|
||
|
||
getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketEditR shar proj num = do
|
||
(tid, ticket, wid) <- runDB $ do
|
||
Entity sid _sharer <- getBy404 $ UniqueSharer shar
|
||
Entity pid project <- getBy404 $ UniqueProject proj sid
|
||
Entity tid ticket <- getBy404 $ UniqueTicket pid num
|
||
return (tid, ticket, projectWorkflow project)
|
||
((_result, widget), enctype) <-
|
||
runFormPost $ editTicketContentForm tid ticket wid
|
||
defaultLayout $(widgetFile "ticket/edit")
|
||
|
||
postTicketAcceptR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketAcceptR shr prj num = do
|
||
succ <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ticketStatus ticket of
|
||
TSNew -> do
|
||
update tid [TicketStatus =. TSTodo]
|
||
return True
|
||
_ -> return False
|
||
setMessage $
|
||
if succ
|
||
then "Ticket accepted."
|
||
else "Ticket is already accepted."
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketCloseR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketCloseR shr prj num = do
|
||
pid <- requireAuthId
|
||
now <- liftIO getCurrentTime
|
||
succ <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ticketStatus ticket of
|
||
TSClosed -> return False
|
||
_ -> do
|
||
update tid
|
||
[ TicketAssignee =. Nothing
|
||
, TicketStatus =. TSClosed
|
||
, TicketClosed =. now
|
||
, TicketCloser =. pid
|
||
]
|
||
return True
|
||
setMessage $
|
||
if succ
|
||
then "Ticket closed."
|
||
else "Ticket is already closed."
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketOpenR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketOpenR shr prj num = do
|
||
pid <- requireAuthId
|
||
now <- liftIO getCurrentTime
|
||
succ <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ticketStatus ticket of
|
||
TSClosed -> do
|
||
update tid
|
||
[ TicketStatus =. TSTodo
|
||
, TicketCloser =. ticketCreator ticket
|
||
]
|
||
return True
|
||
_ -> return False
|
||
setMessage $
|
||
if succ
|
||
then "Ticket reopened"
|
||
else "Ticket is already open."
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketClaimR shr prj num = do
|
||
pid <- requireAuthId
|
||
mmsg <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case (ticketStatus ticket, ticketAssignee ticket) of
|
||
(TSNew, _) ->
|
||
return $
|
||
Just "The ticket isn’t accepted yet. Can’t claim it."
|
||
(TSClosed, _) ->
|
||
return $
|
||
Just "The ticket is closed. Can’t claim closed tickets."
|
||
(TSTodo, Just _) ->
|
||
return $
|
||
Just "The ticket is already assigned to someone."
|
||
(TSTodo, Nothing) -> do
|
||
update tid [TicketAssignee =. Just pid]
|
||
return Nothing
|
||
setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
|
||
redirect $ TicketR shr prj num
|
||
|
||
postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketUnclaimR shr prj num = do
|
||
pid <- requireAuthId
|
||
mmsg <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
|
||
(Nothing, _) ->
|
||
return $ Just "The ticket is already unassigned."
|
||
(Just False, _) ->
|
||
return $ Just "The ticket is assigned to someone else."
|
||
(Just True, TSNew) -> do
|
||
$logWarn "Found a new claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket isn’t accepted yet. Can’t unclaim it."
|
||
(Just True, TSClosed) -> do
|
||
$logWarn "Found a closed claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket is closed. Can’t unclaim closed tickets."
|
||
(Just True, TSTodo) -> do
|
||
update tid [TicketAssignee =. Nothing]
|
||
return Nothing
|
||
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
|
||
redirect $ TicketR shr prj num
|
||
|
||
getTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketAssignR shr prj num = do
|
||
vpid <- requireAuthId
|
||
(jid, Entity tid ticket) <- runDB $ do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity j _ <- getBy404 $ UniqueProject prj s
|
||
et <- getBy404 $ UniqueTicket j num
|
||
return (j, et)
|
||
let msg t = do
|
||
setMessage t
|
||
redirect $ TicketR shr prj num
|
||
case (ticketStatus ticket, ticketAssignee ticket) of
|
||
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
|
||
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
|
||
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
|
||
(TSTodo, Nothing) -> do
|
||
((_result, widget), enctype) <-
|
||
runFormPost $ assignTicketForm vpid jid
|
||
defaultLayout $(widgetFile "ticket/assign")
|
||
|
||
postTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketAssignR shr prj num = do
|
||
vpid <- requireAuthId
|
||
(jid, Entity tid ticket) <- runDB $ do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity j _ <- getBy404 $ UniqueProject prj s
|
||
et <- getBy404 $ UniqueTicket j num
|
||
return (j, et)
|
||
let msg t = do
|
||
setMessage t
|
||
redirect $ TicketR shr prj num
|
||
case (ticketStatus ticket, ticketAssignee ticket) of
|
||
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
|
||
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
|
||
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
|
||
(TSTodo, Nothing) -> do
|
||
((result, widget), enctype) <-
|
||
runFormPost $ assignTicketForm vpid jid
|
||
case result of
|
||
FormSuccess pid -> do
|
||
sharer <- runDB $ do
|
||
update tid [TicketAssignee =. Just pid]
|
||
person <- getJust pid
|
||
getJust $ personIdent person
|
||
let si = sharerIdent sharer
|
||
msg $ toHtml $
|
||
"The ticket is now assigned to " <> shr2text si <> "."
|
||
FormMissing -> do
|
||
setMessage "Field(s) missing."
|
||
defaultLayout $(widgetFile "ticket/assign")
|
||
FormFailure _l -> do
|
||
setMessage "Ticket assignment failed, see errors below."
|
||
defaultLayout $(widgetFile "ticket/assign")
|
||
|
||
postTicketUnassignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketUnassignR shr prj num = do
|
||
pid <- requireAuthId
|
||
mmsg <- runDB $ do
|
||
Entity tid ticket <- do
|
||
Entity s _ <- getBy404 $ UniqueSharer shr
|
||
Entity p _ <- getBy404 $ UniqueProject prj s
|
||
getBy404 $ UniqueTicket p num
|
||
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
|
||
(Nothing, _) ->
|
||
return $ Just "The ticket is already unassigned."
|
||
(Just True, _) ->
|
||
return $ Just "The ticket is assigned to you, unclaim instead."
|
||
(Just False, TSNew) -> do
|
||
$logWarn "Found a new claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket isn’t accepted yet. Can’t unclaim it."
|
||
(Just False, TSClosed) -> do
|
||
$logWarn "Found a closed claimed ticket, this is invalid"
|
||
return $
|
||
Just "The ticket is closed. Can’t unclaim closed tickets."
|
||
(Just False, TSTodo) -> do
|
||
update tid [TicketAssignee =. Nothing]
|
||
return Nothing
|
||
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
|
||
redirect $ TicketR shr prj num
|
||
|
||
-- | The logged-in user gets a list of the ticket claim requests they have
|
||
-- opened, in any project.
|
||
getClaimRequestsPersonR :: Handler Html
|
||
getClaimRequestsPersonR = do
|
||
pid <- requireAuthId
|
||
rqs <- runDB $ select $ from $
|
||
\ (tcr `InnerJoin` ticket `InnerJoin` project `InnerJoin` sharer) -> do
|
||
on $ project ^. ProjectSharer ==. sharer ^. SharerId
|
||
on $ ticket ^. TicketProject ==. project ^. ProjectId
|
||
on $ tcr ^. TicketClaimRequestTicket ==. ticket ^. TicketId
|
||
where_ $ tcr ^. TicketClaimRequestPerson ==. val pid
|
||
orderBy [desc $ tcr ^. TicketClaimRequestCreated]
|
||
return
|
||
( sharer ^. SharerIdent
|
||
, project ^. ProjectIdent
|
||
, ticket ^. TicketNumber
|
||
, ticket ^. TicketTitle
|
||
, tcr ^. 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
|
||
select $ from $
|
||
\ ( tcr `InnerJoin`
|
||
ticket `InnerJoin`
|
||
person `InnerJoin`
|
||
sharer
|
||
) -> do
|
||
on $ person ^. PersonIdent ==. sharer ^. SharerId
|
||
on $ tcr ^. TicketClaimRequestPerson ==. person ^. PersonId
|
||
on $ tcr ^. TicketClaimRequestTicket ==. ticket ^. TicketId
|
||
where_ $ ticket ^. TicketProject ==. val jid
|
||
orderBy [desc $ tcr ^. TicketClaimRequestCreated]
|
||
return
|
||
( sharer
|
||
, ticket ^. TicketNumber
|
||
, ticket ^. TicketTitle
|
||
, tcr ^. 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
|
||
select $ from $ \ (tcr `InnerJoin` person `InnerJoin` sharer) -> do
|
||
on $ person ^. PersonIdent ==. sharer ^. SharerId
|
||
on $ tcr ^. TicketClaimRequestPerson ==. person ^. PersonId
|
||
where_ $ tcr ^. TicketClaimRequestTicket ==. val tid
|
||
orderBy [desc $ tcr ^. 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 =
|
||
getDiscussion
|
||
(TicketReplyR shar proj num)
|
||
(TicketTopReplyR shar proj num)
|
||
(selectDiscussionId shar proj num)
|
||
|
||
postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketDiscussionR shar proj num =
|
||
postTopReply
|
||
(TicketDiscussionR shar proj num)
|
||
(const $ TicketR shar proj num)
|
||
(selectDiscussionId shar proj num)
|
||
|
||
getTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||
getTicketMessageR shar proj tnum cnum =
|
||
getMessage
|
||
(TicketReplyR shar proj tnum)
|
||
(selectDiscussionId shar proj tnum)
|
||
cnum
|
||
|
||
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||
postTicketMessageR shar proj tnum cnum =
|
||
postReply
|
||
(TicketReplyR shar proj tnum)
|
||
(TicketMessageR shar proj tnum)
|
||
(const $ TicketR shar proj tnum)
|
||
(selectDiscussionId shar proj tnum)
|
||
cnum
|
||
|
||
getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketTopReplyR shar proj num =
|
||
getTopReply $ TicketDiscussionR shar proj num
|
||
|
||
getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||
getTicketReplyR shar proj tnum cnum =
|
||
getReply
|
||
(TicketReplyR shar proj tnum)
|
||
(TicketMessageR shar proj tnum)
|
||
(selectDiscussionId shar proj tnum)
|
||
cnum
|
||
|
||
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
|
||
select $ from $
|
||
\ ( td `InnerJoin`
|
||
ticket `InnerJoin`
|
||
person `InnerJoin`
|
||
sharer
|
||
) -> do
|
||
on $ person ^. PersonIdent ==. sharer ^. SharerId
|
||
on $ ticket ^. TicketCreator ==. person ^. PersonId
|
||
on $ td ^. to' ==. ticket ^. TicketId
|
||
where_ $ td ^. from' ==. val tid
|
||
orderBy [asc $ ticket ^. TicketNumber]
|
||
return
|
||
( ticket ^. TicketNumber
|
||
, sharer
|
||
, ticket ^. TicketTitle
|
||
, ticket ^. TicketStatus
|
||
)
|
||
defaultLayout $(widgetFile "ticket/dep/list")
|
||
|
||
getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketDepsR = getTicketDeps True
|
||
|
||
postTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
postTicketDepsR shr prj num = do
|
||
(jid, tid) <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
Entity tid _ <- getBy404 $ UniqueTicket jid num
|
||
return (jid, tid)
|
||
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
|
||
case result of
|
||
FormSuccess ctid -> do
|
||
runDB $ do
|
||
let td = TicketDependency
|
||
{ ticketDependencyParent = tid
|
||
, ticketDependencyChild = ctid
|
||
}
|
||
insert_ td
|
||
trrFix td ticketDepGraph
|
||
setMessage "Ticket dependency added."
|
||
redirect $ TicketR shr prj num
|
||
FormMissing -> do
|
||
setMessage "Field(s) missing."
|
||
defaultLayout $(widgetFile "ticket/dep/new")
|
||
FormFailure _l -> do
|
||
setMessage "Submission failed, see errors below."
|
||
defaultLayout $(widgetFile "ticket/dep/new")
|
||
|
||
getTicketDepNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketDepNewR shr prj num = do
|
||
(jid, tid) <- runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
Entity tid _ <- getBy404 $ UniqueTicket jid num
|
||
return (jid, tid)
|
||
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
|
||
defaultLayout $(widgetFile "ticket/dep/new")
|
||
|
||
postTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||
postTicketDepR shr prj pnum cnum = do
|
||
mmethod <- lookupPostParam "_method"
|
||
case mmethod of
|
||
Just "DELETE" -> deleteTicketDepR shr prj pnum cnum
|
||
_ -> notFound
|
||
|
||
deleteTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
|
||
deleteTicketDepR shr prj pnum cnum = do
|
||
runDB $ do
|
||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||
Entity jid _ <- getBy404 $ UniqueProject prj sid
|
||
Entity ptid _ <- getBy404 $ UniqueTicket jid pnum
|
||
Entity ctid _ <- getBy404 $ UniqueTicket jid cnum
|
||
Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
|
||
delete tdid
|
||
setMessage "Ticket dependency removed."
|
||
redirect $ TicketDepsR shr prj pnum
|
||
|
||
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||
getTicketReverseDepsR = getTicketDeps False
|