{- This file is part of Vervis.
-
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Handler.Ticket
( getTicketsR
, postTicketsR
, getTicketTreeR
, getTicketNewR
, getTicketR
, putTicketR
, deleteTicketR
, postTicketR
, getTicketEditR
, postTicketAcceptR
, postTicketCloseR
, postTicketOpenR
, postTicketClaimR
, postTicketUnclaimR
, getTicketAssignR
, postTicketAssignR
, postTicketUnassignR
, getClaimRequestsPersonR
, getClaimRequestsProjectR
, getClaimRequestsTicketR
, postClaimRequestsTicketR
, getClaimRequestNewR
, getTicketDiscussionR
, postTicketDiscussionR
, getMessageR
, postTicketMessageR
, getTicketTopReplyR
, getTicketReplyR
, getTicketDepsR
, postTicketDepsR
, getTicketDepNewR
, postTicketDepR
, deleteTicketDepR
, getTicketReverseDepsR
, getTicketParticipantsR
, getTicketTeamR
, getTicketEventsR
)
where
import Prelude
import Control.Applicative (liftA2)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logWarn)
import Data.Bifunctor
import Data.Bool (bool)
import Data.Default.Class (def)
import Data.Foldable (traverse_)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Traversable (for)
import Database.Persist
import Network.HTTP.Types (StdMethod (DELETE, POST))
import Text.Blaze.Html (Html, toHtml)
import Text.Blaze.Html.Renderer.Text
import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Core
import Yesod.Core.Handler
import Yesod.Form.Functions (runFormGet, runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Data.Text as T (filter, intercalate, pack)
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
import Data.Aeson.Encode.Pretty.ToEncoding
import Network.FedURI
import Web.ActivityPub hiding (Ticket (..))
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import qualified Web.ActivityPub as AP
import Data.Maybe.Local (partitionMaybePairs)
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph)
import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Model.Workflow
import Vervis.Render
import Vervis.Settings
import Vervis.Style
import Vervis.Ticket
import Vervis.TicketFilter (filterTickets)
import Vervis.Time (showDate)
import Vervis.Widget (buttonW)
import Vervis.Widget.Discussion (discussionW)
import Vervis.Widget.Sharer (personLinkW)
import Vervis.Widget.Ticket
getTicketsR :: ShrIdent -> PrjIdent -> Handler Html
getTicketsR shr prj = do
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
let tf =
case filtResult of
FormSuccess filt -> filt
FormMissing -> def
FormFailure l ->
error $ "Ticket filter form failed: " ++ show l
rows <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
getTicketSummaries
(filterTickets tf)
(Just $ \ t -> [E.asc $ t E.^. TicketNumber])
jid
defaultLayout $(widgetFile "ticket/list")
postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
postTicketsR shar proj = do
Entity pid project <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shar
getBy404 $ UniqueProject proj sid
((result, widget), enctype) <-
runFormPost $ newTicketForm $ projectWorkflow project
case result of
FormSuccess nt -> do
author <- requireAuthId
now <- liftIO getCurrentTime
let source = ntDesc nt
descHtml <-
case renderPandocMarkdown source of
Left err -> do
setMessage $ toHtml err
redirect $ TicketNewR shar proj
Right t -> return t
tnum <- runDB $ do
update pid [ProjectNextTicket +=. 1]
did <- insert Discussion
fsid <- insert FollowerSet
let ticket = Ticket
{ ticketProject = pid
, ticketNumber = projectNextTicket project
, ticketCreated = now
, ticketCreator = author
, ticketTitle = ntTitle nt
, ticketSource = source
, ticketDescription = descHtml
, ticketAssignee = Nothing
, ticketStatus = TSNew
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
, ticketCloser = author
, ticketDiscuss = did
, ticketFollowers = fsid
}
tid <- insert ticket
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
, ticketParamTextValue = v
}
insertMany_ $ map mktparam $ ntTParams nt
let mkeparam (fid, v) = TicketParamEnum
{ ticketParamEnumTicket = tid
, ticketParamEnumField = fid
, ticketParamEnumValue = v
}
insertMany_ $ map mkeparam $ ntEParams nt
return $ ticketNumber ticket
setMessage "Ticket created."
redirect $ TicketR shar proj tnum
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/new")
FormFailure _l -> do
setMessage "Ticket creation failed, see errors below."
defaultLayout $(widgetFile "ticket/new")
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getTicketTreeR shr prj = do
(summaries, deps) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
liftA2 (,)
(getTicketSummaries Nothing Nothing jid)
(getTicketDepEdges jid)
defaultLayout $ ticketTreeDW shr prj summaries deps
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getTicketNewR shar proj = do
wid <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shar
Entity _ j <- getBy404 $ UniqueProject proj sid
return $ projectWorkflow j
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
defaultLayout $(widgetFile "ticket/new")
getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketR shar proj num = do
mpid <- maybeAuthId
( wshr, wfl,
author, massignee, closer, ticket, tparams, eparams, deps, rdeps) <-
runDB $ do
(jid, wshr, wid, wfl) <- do
Entity s sharer <- getBy404 $ UniqueSharer shar
Entity p project <- getBy404 $ UniqueProject proj s
w <- get404 $ projectWorkflow project
wsharer <-
if workflowSharer w == s
then return sharer
else get404 $ workflowSharer w
return
( p
, sharerIdent wsharer
, projectWorkflow project
, workflowIdent w
)
Entity tid ticket <- getBy404 $ UniqueTicket jid num
author <- do
person <- get404 $ ticketCreator ticket
get404 $ personIdent person
massignee <- for (ticketAssignee ticket) $ \ apid -> do
person <- get404 apid
sharer <- get404 $ personIdent person
return (sharer, fromMaybe False $ (== apid) <$> mpid)
closer <-
case ticketStatus ticket of
TSClosed -> do
person <- get404 $ ticketCloser ticket
get404 $ personIdent person
_ -> return author
tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams tid wid
deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
return t
rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do
E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
return t
return
( wshr, wfl
, author, massignee, closer, ticket, tparams, eparams
, deps, rdeps
)
encodeHid <- getEncodeKeyHashid
let desc :: Widget
desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
discuss =
discussionW
(return $ ticketDiscuss ticket)
(TicketTopReplyR shar proj num)
(TicketReplyR shar proj num . encodeHid)
cRelevant <- newIdent
cIrrelevant <- newIdent
let relevant filt =
bool cIrrelevant cRelevant $
case ticketStatus ticket of
TSNew -> wffNew filt
TSTodo -> wffTodo filt
TSClosed -> wffClosed filt
hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let siblingUri =
encodeRouteHome . TicketR shar proj . ticketNumber . entityVal
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 =
encodeRouteLocal $ SharerR $ sharerIdent author
, AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing
, AP.ticketName = Just $ "#" <> T.pack (show num)
, AP.ticketSummary =
TextHtml $ TL.toStrict $ renderHtml $ toHtml $
ticketTitle ticket
, AP.ticketContent = TextHtml $ ticketDescription ticket
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
, AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
, AP.ticketDependsOn = map siblingUri deps
, AP.ticketDependedBy = map siblingUri rdeps
}
provideHtmlAndAP ticketAP $(widgetFile "ticket/one")
putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
putTicketR shar proj num = do
(tid, ticket, wid) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid project <- getBy404 $ UniqueProject proj sid
Entity tid ticket <- getBy404 $ UniqueTicket pid num
return (tid, ticket, projectWorkflow project)
((result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid
case result of
FormSuccess (ticket', tparams, eparams) -> do
newDescHtml <-
case renderPandocMarkdown $ ticketSource ticket' of
Left err -> do
setMessage $ toHtml err
redirect $ TicketEditR shar proj num
Right t -> return t
let ticket'' = ticket' { ticketDescription = newDescHtml }
runDB $ do
replace tid ticket''
let (tdel, tins, tupd) = partitionMaybePairs tparams
deleteWhere [TicketParamTextId <-. tdel]
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
, ticketParamTextValue = v
}
insertMany_ $ map mktparam tins
traverse_
(\ (aid, (_fid, v)) ->
update aid [TicketParamTextValue =. v]
)
tupd
let (edel, eins, eupd) = partitionMaybePairs eparams
deleteWhere [TicketParamEnumId <-. edel]
let mkeparam (fid, v) = TicketParamEnum
{ ticketParamEnumTicket = tid
, ticketParamEnumField = fid
, ticketParamEnumValue = v
}
insertMany_ $ map mkeparam eins
traverse_
(\ (aid, (_fid, v)) ->
update aid [TicketParamEnumValue =. v]
)
eupd
setMessage "Ticket updated."
redirect $ TicketR shar proj num
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/edit")
FormFailure _l -> do
setMessage "Ticket update failed, see errors below."
defaultLayout $(widgetFile "ticket/edit")
deleteTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
deleteTicketR shar proj num =
--TODO: I can easily implement this, but should it even be possible to
--delete tickets?
error "Not implemented"
postTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketR shar proj num = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "PUT" -> putTicketR shar proj num
Just "DELETE" -> deleteTicketR shar proj num
_ -> notFound
getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketEditR shar proj num = do
(tid, ticket, wid) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid project <- getBy404 $ UniqueProject proj sid
Entity tid ticket <- getBy404 $ UniqueTicket pid num
return (tid, ticket, projectWorkflow project)
((_result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid
defaultLayout $(widgetFile "ticket/edit")
postTicketAcceptR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketAcceptR shr prj num = do
succ <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
getBy404 $ UniqueTicket p num
case ticketStatus ticket of
TSNew -> do
update tid [TicketStatus =. TSTodo]
return True
_ -> return False
setMessage $
if succ
then "Ticket accepted."
else "Ticket is already accepted."
redirect $ TicketR shr prj num
postTicketCloseR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketCloseR shr prj num = do
pid <- requireAuthId
now <- liftIO getCurrentTime
succ <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
getBy404 $ UniqueTicket p num
case ticketStatus ticket of
TSClosed -> return False
_ -> do
update tid
[ TicketAssignee =. Nothing
, TicketStatus =. TSClosed
, TicketClosed =. now
, TicketCloser =. pid
]
return True
setMessage $
if succ
then "Ticket closed."
else "Ticket is already closed."
redirect $ TicketR shr prj num
postTicketOpenR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketOpenR shr prj num = do
pid <- requireAuthId
now <- liftIO getCurrentTime
succ <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
getBy404 $ UniqueTicket p num
case ticketStatus ticket of
TSClosed -> do
update tid
[ TicketStatus =. TSTodo
, TicketCloser =. ticketCreator ticket
]
return True
_ -> return False
setMessage $
if succ
then "Ticket reopened"
else "Ticket is already open."
redirect $ TicketR shr prj num
postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketClaimR shr prj num = do
pid <- requireAuthId
mmsg <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
getBy404 $ UniqueTicket p num
case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) ->
return $
Just "The ticket isn’t accepted yet. Can’t claim it."
(TSClosed, _) ->
return $
Just "The ticket is closed. Can’t claim closed tickets."
(TSTodo, Just _) ->
return $
Just "The ticket is already assigned to someone."
(TSTodo, Nothing) -> do
update tid [TicketAssignee =. Just pid]
return Nothing
setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
redirect $ TicketR shr prj num
postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketUnclaimR shr prj num = do
pid <- requireAuthId
mmsg <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
getBy404 $ UniqueTicket p num
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) ->
return $ Just "The ticket is already unassigned."
(Just False, _) ->
return $ Just "The ticket is assigned to someone else."
(Just True, TSNew) -> do
$logWarn "Found a new claimed ticket, this is invalid"
return $
Just "The ticket isn’t accepted yet. Can’t unclaim it."
(Just True, TSClosed) -> do
$logWarn "Found a closed claimed ticket, this is invalid"
return $
Just "The ticket is closed. Can’t unclaim closed tickets."
(Just True, TSTodo) -> do
update tid [TicketAssignee =. Nothing]
return Nothing
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
redirect $ TicketR shr prj num
getTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketAssignR shr prj num = do
vpid <- requireAuthId
(jid, Entity tid ticket) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
et <- getBy404 $ UniqueTicket j num
return (j, et)
let msg t = do
setMessage t
redirect $ TicketR shr prj num
case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
(TSTodo, Nothing) -> do
((_result, widget), enctype) <-
runFormPost $ assignTicketForm vpid jid
defaultLayout $(widgetFile "ticket/assign")
postTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketAssignR shr prj num = do
vpid <- requireAuthId
(jid, Entity tid ticket) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
et <- getBy404 $ UniqueTicket j num
return (j, et)
let msg t = do
setMessage t
redirect $ TicketR shr prj num
case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
(TSTodo, Nothing) -> do
((result, widget), enctype) <-
runFormPost $ assignTicketForm vpid jid
case result of
FormSuccess pid -> do
sharer <- runDB $ do
update tid [TicketAssignee =. Just pid]
person <- getJust pid
getJust $ personIdent person
let si = sharerIdent sharer
msg $ toHtml $
"The ticket is now assigned to " <> shr2text si <> "."
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/assign")
FormFailure _l -> do
setMessage "Ticket assignment failed, see errors below."
defaultLayout $(widgetFile "ticket/assign")
postTicketUnassignR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketUnassignR shr prj num = do
pid <- requireAuthId
mmsg <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
getBy404 $ UniqueTicket p num
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) ->
return $ Just "The ticket is already unassigned."
(Just True, _) ->
return $ Just "The ticket is assigned to you, unclaim instead."
(Just False, TSNew) -> do
$logWarn "Found a new claimed ticket, this is invalid"
return $
Just "The ticket isn’t accepted yet. Can’t unclaim it."
(Just False, TSClosed) -> do
$logWarn "Found a closed claimed ticket, this is invalid"
return $
Just "The ticket is closed. Can’t unclaim closed tickets."
(Just False, TSTodo) -> do
update tid [TicketAssignee =. Nothing]
return Nothing
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
redirect $ TicketR shr prj num
-- | The logged-in user gets a list of the ticket claim requests they have
-- opened, in any project.
getClaimRequestsPersonR :: Handler Html
getClaimRequestsPersonR = do
pid <- requireAuthId
rqs <- runDB $ E.select $ E.from $
\ (tcr `E.InnerJoin` ticket `E.InnerJoin` project `E.InnerJoin` sharer) -> do
E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId
E.on $ ticket E.^. TicketProject E.==. project E.^. ProjectId
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return
( sharer E.^. SharerIdent
, project E.^. ProjectIdent
, ticket E.^. TicketNumber
, ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated
)
defaultLayout $(widgetFile "person/claim-requests")
-- | Get a list of ticket claim requests for a given project.
getClaimRequestsProjectR :: ShrIdent -> PrjIdent -> Handler Html
getClaimRequestsProjectR shr prj = do
rqs <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
E.select $ E.from $
\ ( tcr `E.InnerJoin`
ticket `E.InnerJoin`
person `E.InnerJoin`
sharer
) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
E.where_ $ ticket E.^. TicketProject E.==. E.val jid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return
( sharer
, ticket E.^. TicketNumber
, ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated
)
defaultLayout $(widgetFile "project/claim-request/list")
-- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getClaimRequestsTicketR shr prj num = do
rqs <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity tid _ <- getBy404 $ UniqueTicket jid num
E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
E.where_ $ tcr E.^. TicketClaimRequestTicket E.==. E.val tid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return (sharer, tcr)
defaultLayout $(widgetFile "ticket/claim-request/list")
getClaimRequestNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getClaimRequestNewR shr prj num = do
((_result, widget), etype) <- runFormPost claimRequestForm
defaultLayout $(widgetFile "ticket/claim-request/new")
postClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postClaimRequestsTicketR shr prj num = do
((result, widget), etype) <- runFormPost claimRequestForm
case result of
FormSuccess msg -> do
now <- liftIO getCurrentTime
pid <- requireAuthId
runDB $ do
tid <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
Entity t _ <- getBy404 $ UniqueTicket j num
return t
let cr = TicketClaimRequest
{ ticketClaimRequestPerson = pid
, ticketClaimRequestTicket = tid
, ticketClaimRequestMessage = msg
, ticketClaimRequestCreated = now
}
insert_ cr
setMessage "Ticket claim request opened."
redirect $ TicketR shr prj num
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/claim-request/new")
FormFailure _l -> do
setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/claim-request/new")
selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId
selectDiscussionId shar proj tnum = do
Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid _project <- getBy404 $ UniqueProject proj sid
Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum
return $ ticketDiscuss ticket
getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDiscussionR shar proj num = do
encodeHid <- getEncodeKeyHashid
getDiscussion
(TicketReplyR shar proj num . encodeHid)
(TicketTopReplyR shar proj num)
(selectDiscussionId shar proj num)
postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketDiscussionR shr prj num = do
hLocal <- getsYesod $ appInstanceHost . appSettings
postTopReply
hLocal
[ProjectR shr prj]
[TicketParticipantsR shr prj num, TicketTeamR shr prj num]
(TicketR shr prj num)
(TicketDiscussionR shr prj num)
(const $ TicketR shr prj num)
getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
getMessageR shr hid = do
lmid <- decodeKeyHashid404 hid
getDiscussionMessage shr lmid
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
postTicketMessageR shr prj num mkhid = do
encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 mkhid
hLocal <- getsYesod $ appInstanceHost . appSettings
postReply
hLocal
[ProjectR shr prj]
[TicketParticipantsR shr prj num, TicketTeamR shr prj num]
(TicketR shr prj num)
(TicketReplyR shr prj num . encodeHid)
(TicketMessageR shr prj num . encodeHid)
(const $ TicketR shr prj num)
(selectDiscussionId shr prj num)
mid
getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketTopReplyR shar proj num =
getTopReply $ TicketDiscussionR shar proj num
getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
getTicketReplyR shar proj tnum hid = do
encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 hid
getReply
(TicketReplyR shar proj tnum . encodeHid)
(TicketMessageR shar proj tnum . encodeHid)
(selectDiscussionId shar proj tnum)
mid
getTicketDeps :: Bool -> ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDeps forward shr prj num = do
let from' =
if forward then TicketDependencyParent else TicketDependencyChild
to' =
if forward then TicketDependencyChild else TicketDependencyParent
rows <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity tid _ <- getBy404 $ UniqueTicket jid num
E.select $ E.from $
\ ( td `E.InnerJoin`
ticket `E.InnerJoin`
person `E.InnerJoin`
sharer
) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ ticket E.^. TicketCreator E.==. person E.^. PersonId
E.on $ td E.^. to' E.==. ticket E.^. TicketId
E.where_ $ td E.^. from' E.==. E.val tid
E.orderBy [E.asc $ ticket E.^. TicketNumber]
return
( ticket E.^. TicketNumber
, sharer
, ticket E.^. TicketTitle
, ticket E.^. TicketStatus
)
defaultLayout $(widgetFile "ticket/dep/list")
getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDepsR = getTicketDeps True
postTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
postTicketDepsR shr prj num = do
(jid, tid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity tid _ <- getBy404 $ UniqueTicket jid num
return (jid, tid)
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
case result of
FormSuccess ctid -> do
runDB $ do
let td = TicketDependency
{ ticketDependencyParent = tid
, ticketDependencyChild = ctid
}
insert_ td
trrFix td ticketDepGraph
setMessage "Ticket dependency added."
redirect $ TicketR shr prj num
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/dep/new")
FormFailure _l -> do
setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/dep/new")
getTicketDepNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDepNewR shr prj num = do
(jid, tid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity tid _ <- getBy404 $ UniqueTicket jid num
return (jid, tid)
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
defaultLayout $(widgetFile "ticket/dep/new")
postTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
postTicketDepR shr prj pnum cnum = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteTicketDepR shr prj pnum cnum
_ -> notFound
deleteTicketDepR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html
deleteTicketDepR shr prj pnum cnum = do
runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
Entity ptid _ <- getBy404 $ UniqueTicket jid pnum
Entity ctid _ <- getBy404 $ UniqueTicket jid cnum
Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
delete tdid
setMessage "Ticket dependency removed."
redirect $ TicketDepsR shr prj pnum
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketReverseDepsR = getTicketDeps False
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketParticipantsR shr prj num = do
(locals, remotes) <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid
t <- getValBy404 $ UniqueTicket jid num
let fsid = ticketFollowers t
(,) <$> do pids <- map (followPerson . entityVal) <$>
selectList [FollowTarget ==. fsid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
<*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
return
( i E.^. InstanceHost
, ra E.^. RemoteActorIdent
)
hLocal <- getsYesod $ appInstanceHost . appSettings
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let doc = Doc hLocal Collection
{ collectionId =
encodeRouteLocal $ TicketParticipantsR shr prj num
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length locals + length remotes
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . SharerR) locals ++
map (uncurry l2f . bimap E.unValue E.unValue) remotes
}
selectRep $ do
provideAP $ pure doc
provideRep $ defaultLayout $
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketTeamR shr prj num = do
memberShrs <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
_jid <- getKeyBy404 $ UniqueProject prj sid
_tid <- getKeyBy404 $ UniqueTicket _jid num
id_ <-
requireEitherAlt
(getKeyBy $ UniquePersonIdent sid)
(getKeyBy $ UniqueGroup sid)
"Found sharer that is neither person nor group"
"Found sharer that is both person and group"
case id_ of
Left pid -> return [shr]
Right gid -> do
pids <-
map (groupMemberPerson . entityVal) <$>
selectList [GroupMemberGroup ==. gid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
hLocal <- getsYesod $ appInstanceHost . appSettings
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let doc = Doc hLocal Collection
{ collectionId = encodeRouteLocal $ TicketTeamR shr prj num
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length memberShrs
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
}
selectRep $ do
provideAP $ pure doc
provideRep $ defaultLayout $
[whamlet|
<div><pre>#{encodePrettyToLazyText doc}
|]
where
requireEitherAlt
:: Applicative f
=> f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)
requireEitherAlt get1 get2 errNone errBoth = liftA2 mk get1 get2
where
mk Nothing Nothing = error errNone
mk (Just _) (Just _) = error errBoth
mk (Just x) Nothing = Left x
mk Nothing (Just y) = Right y
getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
getTicketEventsR shr prj num = error "TODO not implemented"