{- This file is part of Vervis.
-
- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Handler.Ticket
( getTicketsR
, getTicketTreeR
, getTicketNewR
, getTicketR
, putTicketR
, deleteTicketR
, postTicketR
, getTicketEditR
, postTicketAcceptR
, postTicketCloseR
, postTicketOpenR
, postTicketClaimR
, postTicketUnclaimR
, getTicketAssignR
, postTicketAssignR
, postTicketUnassignR
, getClaimRequestsPersonR
, getClaimRequestsProjectR
, getClaimRequestsTicketR
, postClaimRequestsTicketR
, getClaimRequestNewR
, getTicketDiscussionR
, postTicketDiscussionR
, getMessageR
, postTicketMessageR
, getTicketTopReplyR
, getTicketReplyR
, getTicketDepsR
, postTicketDepsR
, getTicketDepNewR
, postTicketDepOldR
, deleteTicketDepOldR
, getTicketReverseDepsR
, getTicketDepR
, getTicketParticipantsR
, getTicketTeamR
, getTicketEventsR
, getSharerTicketsR
, getSharerTicketR
, getSharerTicketDiscussionR
, getSharerTicketDepsR
, getSharerTicketReverseDepsR
, getSharerTicketFollowersR
, getSharerTicketTeamR
, getSharerTicketEventsR
)
where
import Control.Applicative (liftA2)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Data.Aeson (encode)
import Data.Bifunctor
import Data.Bitraversable
import Data.Bool (bool)
import Data.Default.Class (def)
import Data.Foldable (traverse_)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Traversable (for)
import Database.Persist
import Network.HTTP.Types (StdMethod (DELETE, POST))
import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS
import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Core hiding (logWarn)
import Yesod.Core.Handler
import Yesod.Form.Functions (runFormGet, runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T (filter, intercalate, pack)
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
import Data.Aeson.Encode.Pretty.ToEncoding
import Data.MediaType
import Network.FedURI
import Web.ActivityPub hiding (Ticket (..), TicketDependency)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource
import qualified Web.ActivityPub as AP
import Data.Either.Local
import Data.Maybe.Local (partitionMaybePairs)
import Data.Paginate.Local
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.API
import Vervis.Federation
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Ticket
import Vervis.Model.Workflow
import Vervis.Paginate
import Vervis.Settings
import Vervis.Style
import Vervis.Ticket
import Vervis.TicketFilter (filterTickets)
import Vervis.Time (showDate)
import Vervis.Widget (buttonW)
import Vervis.Widget.Discussion (discussionW)
import Vervis.Widget.Sharer
import Vervis.Widget.Ticket
getTicketsR :: ShrIdent -> PrjIdent -> Handler TypedContent
getTicketsR shr prj = selectRep $ do
provideRep $ do
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
let tf =
case filtResult of
FormSuccess filt -> filt
FormMissing -> def
FormFailure l ->
error $ "Ticket filter form failed: " ++ show l
(total, pages, mpage) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
let countAllTickets = count [TicketProjectLocalProject ==. jid]
selectTickets off lim =
getTicketSummaries
(filterTickets tf)
(Just $ \ t -> [E.asc $ t E.^. TicketId])
(Just (off, lim))
jid
getPageAndNavCount countAllTickets selectTickets
case mpage of
Nothing -> redirectFirstPage here
Just (rows, navModel) ->
let pageNav = navWidget navModel
in defaultLayout $(widgetFile "ticket/list")
provideAP' $ do
(total, pages, mpage) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
let countAllTickets = count [TicketProjectLocalProject ==. jid]
selectTickets off lim = do
tids <-
map (ticketProjectLocalTicket . entityVal) <$>
selectList
[TicketProjectLocalProject ==. jid]
[ Desc TicketProjectLocalTicket
, OffsetBy off
, LimitTo lim
]
selectKeysList [LocalTicketTicket <-. tids] [Desc LocalTicketTicket]
getPageAndNavCount countAllTickets selectTickets
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
encodeRoutePageLocal <- getEncodeRoutePageLocal
let pageUrl = encodeRoutePageLocal here
host <- asksSite siteInstanceHost
encodeTicketKey <- getEncodeKeyHashid
let ticketUrl = TicketR shr prj . encodeTicketKey
return $
case mpage of
Nothing -> encodeStrict $ Doc host $ Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeOrdered
, collectionTotalItems = Just total
, collectionCurrent = Nothing
, collectionFirst = Just $ pageUrl 1
, collectionLast = Just $ pageUrl pages
, collectionItems = [] :: [Text]
}
Just (tickets, navModel) ->
let current = nmCurrent navModel
in encodeStrict $ Doc host $ CollectionPage
{ collectionPageId = pageUrl current
, collectionPageType = CollectionPageTypeOrdered
, collectionPageTotalItems = Nothing
, collectionPageCurrent = Just $ pageUrl current
, collectionPageFirst = Just $ pageUrl 1
, collectionPageLast = Just $ pageUrl pages
, collectionPagePartOf = encodeRouteLocal here
, collectionPagePrev =
if current > 1
then Just $ pageUrl $ current - 1
else Nothing
, collectionPageNext =
if current < pages
then Just $ pageUrl $ current + 1
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems =
map (encodeRouteHome . ticketUrl) tickets
}
where
here = TicketsR shr prj
encodeStrict = BL.toStrict . encode
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getTicketTreeR shr prj = do
(summaries, deps) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
(,) <$> getTicketSummaries Nothing Nothing Nothing jid
<*> getTicketDepEdges jid
defaultLayout $ ticketTreeDW shr prj summaries deps
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getTicketNewR shr prj = do
wid <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity _ j <- getBy404 $ UniqueProject prj sid
return $ projectWorkflow j
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
defaultLayout $(widgetFile "ticket/new")
getTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketR shar proj ltkhid = do
mpid <- maybeAuthId
( wshr, wfl,
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
deps, rdeps) <-
runDB $ do
(jid, wshr, wid, wfl) <- do
Entity s sharer <- getBy404 $ UniqueSharer shar
Entity p project <- getBy404 $ UniqueProject proj s
w <- get404 $ projectWorkflow project
wsharer <-
if workflowSharer w == s
then return sharer
else get404 $ workflowSharer w
return
( p
, sharerIdent wsharer
, projectWorkflow project
, workflowIdent w
)
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
Entity tplid tpl <- getBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
author <-
requireEitherAlt
(do mtal <- getValBy $ UniqueTicketAuthorLocal ltid
for mtal $ \ tal -> do
_ <- getBy404 $ UniqueTicketUnderProjectProject tplid
p <- getJust $ ticketAuthorLocalAuthor tal
getJust $ personIdent p
)
(do mtar <- getValBy $ UniqueTicketAuthorRemote tplid
for mtar $ \ tar -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro, ra)
)
"Ticket doesn't have author"
"Ticket has both local and remote author"
ticket <- get404 tid
massignee <- for (ticketAssignee ticket) $ \ apid -> do
person <- get404 apid
sharer <- get404 $ personIdent person
return (sharer, fromMaybe False $ (== apid) <$> mpid)
mcloser <-
case ticketStatus ticket of
TSClosed ->
case ticketCloser ticket of
Just pidCloser -> Just <$> do
person <- getJust pidCloser
getJust $ personIdent person
Nothing -> error "Closer not set for closed ticket"
_ ->
case ticketCloser ticket of
Just _ -> error "Closer set for open ticket"
Nothing -> return Nothing
tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams tid wid
cparams <- getTicketClasses tid wid
deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
return (lt E.^. LocalTicketId, t)
rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
return (lt E.^. LocalTicketId, t)
return
( wshr, wfl
, author, massignee, mcloser, ticket, lticket
, tparams, eparams, cparams
, deps, rdeps
)
encodeHid <- getEncodeKeyHashid
let desc :: Widget
desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
discuss =
discussionW
(return $ localTicketDiscuss lticket)
(TicketTopReplyR shar proj ltkhid)
(TicketReplyR shar proj ltkhid . encodeHid)
cRelevant <- newIdent
cIrrelevant <- newIdent
let relevant filt =
bool cIrrelevant cRelevant $
case ticketStatus ticket of
TSNew -> wffNew filt
TSTodo -> wffTodo filt
TSClosed -> wffClosed filt
hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let host =
case author of
Left _ -> hLocal
Right (i, _, _) -> instanceHost i
ticketAP = AP.Ticket
{ AP.ticketLocal = Just
( hLocal
, AP.TicketLocal
{ AP.ticketId =
encodeRouteLocal $ TicketR shar proj ltkhid
, AP.ticketContext =
encodeRouteLocal $ ProjectR shar proj
, AP.ticketReplies =
encodeRouteLocal $ TicketDiscussionR shar proj ltkhid
, AP.ticketParticipants =
encodeRouteLocal $ TicketParticipantsR shar proj ltkhid
, AP.ticketTeam =
encodeRouteLocal $ TicketTeamR shar proj ltkhid
, AP.ticketEvents =
encodeRouteLocal $ TicketEventsR shar proj ltkhid
, AP.ticketDeps =
encodeRouteLocal $ TicketDepsR shar proj ltkhid
, AP.ticketReverseDeps =
encodeRouteLocal $ TicketReverseDepsR shar proj ltkhid
}
)
, AP.ticketAttributedTo =
case author of
Left sharer ->
encodeRouteLocal $ SharerR $ sharerIdent sharer
Right (_inztance, object, _actor) ->
remoteObjectIdent object
, AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing
-- , AP.ticketName = Just $ "#" <> T.pack (show num)
, AP.ticketSummary = TextHtml $ ticketTitle ticket
, AP.ticketContent = TextHtml $ ticketDescription ticket
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
, AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
}
provideHtmlAndAP' host ticketAP $
let followButton =
followW
(TicketFollowR shar proj ltkhid)
(TicketUnfollowR shar proj ltkhid)
(return $ localTicketFollowers lticket)
in $(widgetFile "ticket/one")
putTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
putTicketR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
Entity pid project <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == pid) notFound
return (tid, ticket, projectWorkflow project)
((result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid
case result of
FormSuccess (ticket', tparams, eparams, cparams) -> do
newDescHtml <-
case renderPandocMarkdown $ ticketSource ticket' of
Left err -> do
setMessage $ toHtml err
redirect $ TicketEditR shr prj ltkhid
Right t -> return t
let ticket'' = ticket' { ticketDescription = newDescHtml }
runDB $ do
replace tid ticket''
let (tdel, tins, tupd) = partitionMaybePairs tparams
deleteWhere [TicketParamTextId <-. tdel]
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
, ticketParamTextValue = v
}
insertMany_ $ map mktparam tins
traverse_
(\ (aid, (_fid, v)) ->
update aid [TicketParamTextValue =. v]
)
tupd
let (edel, eins, eupd) = partitionMaybePairs eparams
deleteWhere [TicketParamEnumId <-. edel]
let mkeparam (fid, v) = TicketParamEnum
{ ticketParamEnumTicket = tid
, ticketParamEnumField = fid
, ticketParamEnumValue = v
}
insertMany_ $ map mkeparam eins
traverse_
(\ (aid, (_fid, v)) ->
update aid [TicketParamEnumValue =. v]
)
eupd
let (cdel, cins, _ckeep) = partitionMaybePairs cparams
deleteWhere [TicketParamClassId <-. cdel]
let mkcparam fid = TicketParamClass
{ ticketParamClassTicket = tid
, ticketParamClassField = fid
}
insertMany_ $ map mkcparam cins
setMessage "Ticket updated."
redirect $ TicketR shr prj ltkhid
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/edit")
FormFailure _l -> do
setMessage "Ticket update failed, see errors below."
defaultLayout $(widgetFile "ticket/edit")
deleteTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
deleteTicketR _shr _prj _ltkhid =
--TODO: I can easily implement this, but should it even be possible to
--delete tickets?
error "Not implemented"
postTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketR shr prj ltkhid = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "PUT" -> putTicketR shr prj ltkhid
Just "DELETE" -> deleteTicketR shr prj ltkhid
_ -> notFound
getTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketEditR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
Entity pid project <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == pid) notFound
return (tid, ticket, projectWorkflow project)
((_result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid
defaultLayout $(widgetFile "ticket/edit")
postTicketAcceptR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketAcceptR shr prj ltkhid = do
succ <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == p) notFound
return $ Entity tid ticket
case ticketStatus ticket of
TSNew -> do
update tid [TicketStatus =. TSTodo]
return True
_ -> return False
setMessage $
if succ
then "Ticket accepted."
else "Ticket is already accepted."
redirect $ TicketR shr prj ltkhid
postTicketCloseR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketCloseR shr prj ltkhid = do
pid <- requireAuthId
now <- liftIO getCurrentTime
succ <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == p) notFound
return $ Entity tid ticket
case ticketStatus ticket of
TSClosed -> return False
_ -> do
update tid
[ TicketAssignee =. Nothing
, TicketStatus =. TSClosed
, TicketClosed =. now
, TicketCloser =. Just pid
]
return True
setMessage $
if succ
then "Ticket closed."
else "Ticket is already closed."
redirect $ TicketR shr prj ltkhid
postTicketOpenR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketOpenR shr prj ltkhid = do
pid <- requireAuthId
now <- liftIO getCurrentTime
succ <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == p) notFound
return $ Entity tid ticket
case ticketStatus ticket of
TSClosed -> do
update tid
[ TicketStatus =. TSTodo
, TicketCloser =. Nothing
]
return True
_ -> return False
setMessage $
if succ
then "Ticket reopened"
else "Ticket is already open."
redirect $ TicketR shr prj ltkhid
postTicketClaimR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketClaimR shr prj ltkhid = do
pid <- requireAuthId
mmsg <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == p) notFound
return $ Entity tid ticket
case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) ->
return $
Just "The ticket isn’t accepted yet. Can’t claim it."
(TSClosed, _) ->
return $
Just "The ticket is closed. Can’t claim closed tickets."
(TSTodo, Just _) ->
return $
Just "The ticket is already assigned to someone."
(TSTodo, Nothing) -> do
update tid [TicketAssignee =. Just pid]
return Nothing
setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
redirect $ TicketR shr prj ltkhid
postTicketUnclaimR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketUnclaimR shr prj ltkhid = do
pid <- requireAuthId
mmsg <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == p) notFound
return $ Entity tid ticket
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) ->
return $ Just "The ticket is already unassigned."
(Just False, _) ->
return $ Just "The ticket is assigned to someone else."
(Just True, TSNew) -> do
logWarn "Found a new claimed ticket, this is invalid"
return $
Just "The ticket isn’t accepted yet. Can’t unclaim it."
(Just True, TSClosed) -> do
logWarn "Found a closed claimed ticket, this is invalid"
return $
Just "The ticket is closed. Can’t unclaim closed tickets."
(Just True, TSTodo) -> do
update tid [TicketAssignee =. Nothing]
return Nothing
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
redirect $ TicketR shr prj ltkhid
getTicketAssignR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketAssignR shr prj ltkhid = do
vpid <- requireAuthId
(jid, Entity tid ticket) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == j) notFound
return (j, Entity tid ticket)
let msg t = do
setMessage t
redirect $ TicketR shr prj ltkhid
case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
(TSTodo, Nothing) -> do
((_result, widget), enctype) <-
runFormPost $ assignTicketForm vpid jid
defaultLayout $(widgetFile "ticket/assign")
postTicketAssignR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketAssignR shr prj ltkhid = do
vpid <- requireAuthId
(jid, Entity tid ticket) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == j) notFound
return (j, Entity tid ticket)
let msg t = do
setMessage t
redirect $ TicketR shr prj ltkhid
case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
(TSTodo, Just _) -> msg "The ticket is already assigned to someone."
(TSTodo, Nothing) -> do
((result, widget), enctype) <-
runFormPost $ assignTicketForm vpid jid
case result of
FormSuccess pid -> do
sharer <- runDB $ do
update tid [TicketAssignee =. Just pid]
person <- getJust pid
getJust $ personIdent person
let si = sharerIdent sharer
msg $ toHtml $
"The ticket is now assigned to " <> shr2text si <> "."
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/assign")
FormFailure _l -> do
setMessage "Ticket assignment failed, see errors below."
defaultLayout $(widgetFile "ticket/assign")
postTicketUnassignR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketUnassignR shr prj ltkhid = do
pid <- requireAuthId
mmsg <- runDB $ do
Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == p) notFound
return $ Entity tid ticket
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) ->
return $ Just "The ticket is already unassigned."
(Just True, _) ->
return $ Just "The ticket is assigned to you, unclaim instead."
(Just False, TSNew) -> do
logWarn "Found a new claimed ticket, this is invalid"
return $
Just "The ticket isn’t accepted yet. Can’t unclaim it."
(Just False, TSClosed) -> do
logWarn "Found a closed claimed ticket, this is invalid"
return $
Just "The ticket is closed. Can’t unclaim closed tickets."
(Just False, TSTodo) -> do
update tid [TicketAssignee =. Nothing]
return Nothing
setMessage $ fromMaybe "The ticket is now unassigned." mmsg
redirect $ TicketR shr prj ltkhid
-- | The logged-in user gets a list of the ticket claim requests they have
-- opened, in any project.
getClaimRequestsPersonR :: Handler Html
getClaimRequestsPersonR = do
pid <- requireAuthId
rqs <- runDB $ E.select $ E.from $
\ (tcr `E.InnerJoin` ticket `E.InnerJoin` lticket `E.InnerJoin` tpl `E.InnerJoin` project `E.InnerJoin` sharer) -> do
E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId
E.on $ tpl E.^. TicketProjectLocalProject E.==. project E.^. ProjectId
E.on $ ticket E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return
( sharer E.^. SharerIdent
, project E.^. ProjectIdent
, lticket E.^. LocalTicketId
, ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated
)
encodeHid <- getEncodeKeyHashid
defaultLayout $(widgetFile "person/claim-requests")
-- | Get a list of ticket claim requests for a given project.
getClaimRequestsProjectR :: ShrIdent -> PrjIdent -> Handler Html
getClaimRequestsProjectR shr prj = do
rqs <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
E.select $ E.from $
\ ( tcr `E.InnerJoin`
ticket `E.InnerJoin`
lticket `E.InnerJoin`
tpl `E.InnerJoin`
person `E.InnerJoin`
sharer
) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
E.on $ ticket E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
E.where_ $ tpl E.^. TicketProjectLocalProject E.==. E.val jid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return
( sharer
, lticket E.^. LocalTicketId
, ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated
)
encodeHid <- getEncodeKeyHashid
defaultLayout $(widgetFile "project/claim-request/list")
-- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getClaimRequestsTicketR shr prj ltkhid = do
rqs <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
E.where_ $ tcr E.^. TicketClaimRequestTicket E.==. E.val tid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return (sharer, tcr)
defaultLayout $(widgetFile "ticket/claim-request/list")
getClaimRequestNewR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getClaimRequestNewR shr prj ltkhid = do
((_result, widget), etype) <- runFormPost claimRequestForm
defaultLayout $(widgetFile "ticket/claim-request/new")
postClaimRequestsTicketR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postClaimRequestsTicketR shr prj ltkhid = do
((result, widget), etype) <- runFormPost claimRequestForm
case result of
FormSuccess msg -> do
now <- liftIO getCurrentTime
pid <- requireAuthId
runDB $ do
tid <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == j) notFound
return tid
let cr = TicketClaimRequest
{ ticketClaimRequestPerson = pid
, ticketClaimRequestTicket = tid
, ticketClaimRequestMessage = msg
, ticketClaimRequestCreated = now
}
insert_ cr
setMessage "Ticket claim request opened."
redirect $ TicketR shr prj ltkhid
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/claim-request/new")
FormFailure _l -> do
setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/claim-request/new")
selectDiscussionId
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId
selectDiscussionId shr prj ltkhid = do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
Entity jid _project <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
return $ localTicketDiscuss lticket
getTicketDiscussionR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketDiscussionR shar proj ltkhid = do
encodeHid <- getEncodeKeyHashid
getDiscussion
(TicketReplyR shar proj ltkhid . encodeHid)
(TicketTopReplyR shar proj ltkhid)
(selectDiscussionId shar proj ltkhid)
postTicketDiscussionR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketDiscussionR shr prj ltkhid = do
hLocal <- getsYesod $ appInstanceHost . appSettings
postTopReply
hLocal
[ProjectR shr prj]
[ ProjectFollowersR shr prj
, TicketParticipantsR shr prj ltkhid
, TicketTeamR shr prj ltkhid
]
(TicketR shr prj ltkhid)
(ProjectR shr prj)
(TicketDiscussionR shr prj ltkhid)
(const $ TicketR shr prj ltkhid)
getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
getMessageR shr hid = do
lmid <- decodeKeyHashid404 hid
getDiscussionMessage shr lmid
postTicketMessageR
:: ShrIdent
-> PrjIdent
-> KeyHashid LocalTicket
-> KeyHashid Message
-> Handler Html
postTicketMessageR shr prj ltkhid mkhid = do
encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 mkhid
hLocal <- getsYesod $ appInstanceHost . appSettings
postReply
hLocal
[ProjectR shr prj]
[ ProjectFollowersR shr prj
, TicketParticipantsR shr prj ltkhid
, TicketTeamR shr prj ltkhid
]
(TicketR shr prj ltkhid)
(ProjectR shr prj)
(TicketReplyR shr prj ltkhid . encodeHid)
(TicketMessageR shr prj ltkhid . encodeHid)
(const $ TicketR shr prj ltkhid)
(selectDiscussionId shr prj ltkhid)
mid
getTicketTopReplyR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketTopReplyR shr prj ltkhid =
getTopReply $ TicketDiscussionR shr prj ltkhid
getTicketReplyR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid Message -> Handler Html
getTicketReplyR shr prj ltkhid mkhid = do
encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 mkhid
getReply
(TicketReplyR shr prj ltkhid . encodeHid)
(TicketMessageR shr prj ltkhid . encodeHid)
(selectDiscussionId shr prj ltkhid)
mid
getTicketDeps
:: Bool -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDeps forward shr prj ltkhid = do
(deps, rows) <- unzip <$> runDB getDepsFromDB
depsAP <- makeDepsCollection deps
encodeHid <- getEncodeKeyHashid
provideHtmlAndAP depsAP $(widgetFile "ticket/dep/list")
where
getDepsFromDB = do
let from' =
if forward then TicketDependencyParent else TicketDependencyChild
to' =
if forward then TicketDependencyChild else TicketDependencyParent
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
fmap (map toRow) $ E.select $ E.from $
\ ( td
`E.InnerJoin` t
`E.InnerJoin` lt
`E.InnerJoin` tpl
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
) -> do
E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId
E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId
E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
E.on $ E.just (tpl E.^. TicketProjectLocalId) E.==. tar E.?. TicketAuthorRemoteTicket
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
E.on $ E.just (lt E.^. LocalTicketId) E.==. tal E.?. TicketAuthorLocalTicket
E.on $ t E.^. TicketId E.==. tpl E.^. TicketProjectLocalTicket
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ td E.^. to' E.==. t E.^. TicketId
E.where_ $ td E.^. from' E.==. E.val tid
E.orderBy [E.asc $ t E.^. TicketId]
return
( td E.^. TicketDependencyId
, lt E.^. LocalTicketId
, s
, i
, ro
, ra
, t E.^. TicketTitle
, t E.^. TicketStatus
)
where
toRow (E.Value dep, E.Value ltid, ms, mi, mro, mra, E.Value title, E.Value status) =
( dep
, ( ltid
, case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s
(Nothing, Just i, Just ro, Just ra) ->
Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state"
, title
, status
)
)
makeDepsCollection tdids = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodeKeyHashid <- getEncodeKeyHashid
let here =
let route = if forward then TicketDepsR else TicketReverseDepsR
in route shr prj ltkhid
return Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length tdids
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . TicketDepR . encodeKeyHashid) tdids
}
getTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDepsR = getTicketDeps True
postTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketDepsR shr prj ltkhid = do
(jid, tid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
return (jid, tid)
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
case result of
FormSuccess ctid -> do
pidAuthor <- requireVerifiedAuthId
now <- liftIO getCurrentTime
runDB $ do
let td = TicketDependency
{ ticketDependencyParent = tid
, ticketDependencyChild = ctid
, ticketDependencyAuthor = pidAuthor
, ticketDependencySummary = "(A ticket dependency)"
, ticketDependencyCreated = now
}
insert_ td
trrFix td ticketDepGraph
setMessage "Ticket dependency added."
redirect $ TicketR shr prj ltkhid
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/dep/new")
FormFailure _l -> do
setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/dep/new")
getTicketDepNewR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketDepNewR shr prj ltkhid = do
(jid, tid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lticket <- get404 ltid
let tid = localTicketTicket lticket
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
return (jid, tid)
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
defaultLayout $(widgetFile "ticket/dep/new")
postTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
postTicketDepOldR shr prj pnum cnum = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteTicketDepOldR shr prj pnum cnum
_ -> notFound
deleteTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do
runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
pltid <- decodeKeyHashid404 pnum
plt <- get404 pltid
let ptid = localTicketTicket plt
ptpl <- getValBy404 $ UniqueTicketProjectLocal ptid
unless (ticketProjectLocalProject ptpl == jid) notFound
cltid <- decodeKeyHashid404 cnum
clt <- get404 cltid
let ctid = localTicketTicket clt
ctpl <- getValBy404 $ UniqueTicketProjectLocal ctid
unless (ticketProjectLocalProject ctpl == jid) notFound
Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
delete tdid
setMessage "Ticket dependency removed."
redirect $ TicketDepsR shr prj pnum
getTicketReverseDepsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketReverseDepsR = getTicketDeps False
getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent
getTicketDepR tdkhid = do
tdid <- decodeKeyHashid404 tdkhid
( td,
(sParent, jParent, ltParent),
(sChild, jChild, ltChild),
(sAuthor, pAuthor)
) <- runDB $ do
tdep <- get404 tdid
(,,,) tdep
<$> getTicket (ticketDependencyParent tdep)
<*> getTicket (ticketDependencyChild tdep)
<*> getAuthor (ticketDependencyAuthor tdep)
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let ticketRoute s j lt =
TicketR (sharerIdent s) (projectIdent j) (encodeHid lt)
here = TicketDepR tdkhid
tdepAP = AP.TicketDependency
{ ticketDepId = Just $ encodeRouteHome here
, ticketDepParent =
encodeRouteHome $ ticketRoute sParent jParent ltParent
, ticketDepChild =
encodeRouteHome $ ticketRoute sChild jChild ltChild
, ticketDepAttributedTo =
encodeRouteLocal $ SharerR $ sharerIdent sAuthor
, ticketDepPublished = Just $ ticketDependencyCreated td
, ticketDepUpdated = Just $ ticketDependencyCreated td
, ticketDepSummary = TextHtml $ ticketDependencySummary td
}
provideHtmlAndAP tdepAP $ redirectToPrettyJSON here
where
getTicket tid = do
ltid <- do
mltid <- getKeyBy $ UniqueLocalTicket tid
case mltid of
Nothing -> error "No LocalTicket"
Just v -> return v
tpl <- do
mtpl <- getValBy $ UniqueTicketProjectLocal tid
case mtpl of
Nothing -> error "No TicketProjectLocal"
Just v -> return v
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return (s, j, ltid)
getAuthor pid = do
p <- getJust pid
s <- getJust $ personIdent p
return (s, p)
getTicketParticipantsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFsid
where
here = TicketParticipantsR shr prj ltkhid
getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lt <- get404 ltid
let tid = localTicketTicket lt
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
return $ localTicketFollowers lt
getTicketTeamR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketTeamR shr prj ltkhid = do
memberShrs <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid
ltid <- decodeKeyHashid404 ltkhid
lt <- get404 ltid
let tid = localTicketTicket lt
tpl <- getValBy404 $ UniqueTicketProjectLocal tid
unless (ticketProjectLocalProject tpl == jid) notFound
id_ <-
requireEitherAlt
(getKeyBy $ UniquePersonIdent sid)
(getKeyBy $ UniqueGroup sid)
"Found sharer that is neither person nor group"
"Found sharer that is both person and group"
case id_ of
Left pid -> return [shr]
Right gid -> do
pids <-
map (groupMemberPerson . entityVal) <$>
selectList [GroupMemberGroup ==. gid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
let here = TicketTeamR shr prj ltkhid
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let team = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length memberShrs
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
}
provideHtmlAndAP team $ redirectToPrettyJSON here
getTicketEventsR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"
getSharerTicket
:: ShrIdent
-> KeyHashid TicketAuthorLocal
-> AppDB
( Entity TicketAuthorLocal
, Entity LocalTicket
, Entity Ticket
, Either (Entity TicketProjectLocal) ()
)
getSharerTicket shr talkhid = do
pid <- do
sid <- getKeyBy404 $ UniqueSharer shr
getKeyBy404 $ UniquePersonIdent sid
talid <- decodeKeyHashid404 talkhid
tal <- get404 talid
unless (ticketAuthorLocalAuthor tal == pid) notFound
let ltid = ticketAuthorLocalTicket tal
lt <- getJust ltid
let tid = localTicketTicket lt
t <- getJust tid
project <-
requireEitherAlt
(do mtpl <- getBy $ UniqueTicketProjectLocal tid
for mtpl $ \ etpl@(Entity tplid tpl) -> do
mtup1 <- getBy $ UniqueTicketUnderProjectProject tplid
mtup2 <- getBy $ UniqueTicketUnderProjectAuthor talid
unless (isJust mtup1 == isJust mtup2) $
error "TUP points to unrelated TAL and TPL!"
unless (isNothing mtup1) notFound
return etpl
)
(return Nothing
)
"Ticket doesn't have project"
"Ticket has both local and remote project"
return (Entity talid tal, Entity ltid lt, Entity tid t, project)
getSharerTicketsR :: ShrIdent -> Handler TypedContent
getSharerTicketsR shr = do
(total, pages, mpage) <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
pid <- getKeyBy404 $ UniquePersonIdent sid
getPageAndNavCount (countTickets pid) (selectTickets pid)
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
encodeRoutePageLocal <- getEncodeRoutePageLocal
let pageUrl = encodeRoutePageLocal here
encodeTicketKey <- getEncodeKeyHashid
let ticketUrl = SharerTicketR shr . encodeTicketKey
case mpage of
Nothing -> provide $ Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeOrdered
, collectionTotalItems = Just total
, collectionCurrent = Nothing
, collectionFirst = Just $ pageUrl 1
, collectionLast = Just $ pageUrl pages
, collectionItems = [] :: [Text]
}
Just (tickets, navModel) ->
let current = nmCurrent navModel
in provide $ CollectionPage
{ collectionPageId = pageUrl current
, collectionPageType = CollectionPageTypeOrdered
, collectionPageTotalItems = Nothing
, collectionPageCurrent = Just $ pageUrl current
, collectionPageFirst = Just $ pageUrl 1
, collectionPageLast = Just $ pageUrl pages
, collectionPagePartOf = encodeRouteLocal here
, collectionPagePrev =
if current > 1
then Just $ pageUrl $ current - 1
else Nothing
, collectionPageNext =
if current < pages
then Just $ pageUrl $ current + 1
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems =
map (encodeRouteHome . ticketUrl . E.unValue) tickets
}
where
here = SharerTicketsR shr
provide :: ActivityPub a => a URIMode -> Handler TypedContent
provide a = provideHtmlAndAP a $ redirectToPrettyJSON here
countTickets pid = fmap toOne $
E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do
E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
E.where_ $
tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
E.isNothing (tup E.?. TicketUnderProjectId)
return $ E.count $ tal E.^. TicketAuthorLocalId
where
toOne [x] = E.unValue x
toOne [] = error "toOne = 0"
toOne _ = error "toOne > 1"
selectTickets pid off lim =
E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do
E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor
E.where_ $
tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&.
E.isNothing (tup E.?. TicketUnderProjectId)
E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId]
E.offset $ fromIntegral off
E.limit $ fromIntegral lim
return $ tal E.^. TicketAuthorLocalId
getSharerTicketR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketR shr talkhid = do
(ticket, project, massignee) <- runDB $ do
(_, _, Entity _ t, tp) <- getSharerTicket shr talkhid
(,,) t
<$> bitraverse
(\ (Entity _ tpl) -> do
j <- getJust $ ticketProjectLocalProject tpl
s <- getJust $ projectSharer j
return (s, j)
)
return
tp
<*> (for (ticketAssignee t) $ \ pidAssignee -> do
p <- getJust pidAssignee
getJust $ personIdent p
)
hLocal <- getsYesod siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let ticketAP = AP.Ticket
{ AP.ticketLocal = Just
( hLocal
, AP.TicketLocal
{ AP.ticketId =
encodeRouteLocal $ SharerTicketR shr talkhid
, AP.ticketContext =
encodeRouteLocal $
case project of
Left (s, j) ->
ProjectR (sharerIdent s) (projectIdent j)
Right () -> error "No TPR yet!"
, AP.ticketReplies =
encodeRouteLocal $ SharerTicketDiscussionR shr talkhid
, AP.ticketParticipants =
encodeRouteLocal $ SharerTicketFollowersR shr talkhid
, AP.ticketTeam =
encodeRouteLocal $ SharerTicketTeamR shr talkhid
, AP.ticketEvents =
encodeRouteLocal $ SharerTicketEventsR shr talkhid
, AP.ticketDeps =
encodeRouteLocal $ SharerTicketDepsR shr talkhid
, AP.ticketReverseDeps =
encodeRouteLocal $ SharerTicketReverseDepsR shr talkhid
}
)
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr
, AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing
, AP.ticketSummary = TextHtml $ ticketTitle ticket
, AP.ticketContent = TextHtml $ ticketDescription ticket
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
, AP.ticketAssignedTo =
encodeRouteHome . SharerR . sharerIdent <$> massignee
, AP.ticketIsResolved = ticketStatus ticket == TSClosed
}
provideHtmlAndAP ticketAP $ redirectToPrettyJSON here
where
here = SharerTicketR shr talkhid
getSharerTicketDiscussionR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDiscussionR shr talkhid = do
(locals, remotes) <- runDB $ do
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
let did = localTicketDiscuss lt
(,) <$> selectLocals did <*> selectRemotes did
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let localUri' = localUri encodeRouteHome encodeHid
replies = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length locals + length remotes
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map localUri' locals ++ map remoteUri remotes
}
provideHtmlAndAP replies $ redirectToPrettyJSON here
where
here = SharerTicketDiscussionR shr talkhid
selectLocals did =
E.select $ E.from $
\ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do
E.on $ p E.^. PersonIdent E.==. s E.^. SharerId
E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId
E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest
E.where_ $
m E.^. MessageRoot E.==. E.val did E.&&.
E.isNothing (m E.^. MessageParent) E.&&.
E.isNothing (lm E.^. LocalMessageUnlinkedParent)
return (s E.^. SharerIdent, lm E.^. LocalMessageId)
selectRemotes did =
E.select $ E.from $
\ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId
E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest
E.where_ $
m E.^. MessageRoot E.==. E.val did E.&&.
E.isNothing (m E.^. MessageParent) E.&&.
E.isNothing (rm E.^. RemoteMessageLostParent)
return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent)
localUri encR encH (E.Value shrAuthor, E.Value lmid) =
encR $ MessageR shrAuthor (encH lmid)
remoteUri (E.Value h, E.Value lu) = ObjURI h lu
getSharerTicketDeps
:: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDeps forward shr talkhid = do
tdids <- runDB $ do
(_, _, Entity tid _, _) <- getSharerTicket shr talkhid
let (from, to) =
if forward
then (TicketDependencyParent, TicketDependencyChild)
else (TicketDependencyChild, TicketDependencyParent)
E.select $ E.from $ \ (td `E.InnerJoin` t) -> do
E.on $ td E.^. to E.==. t E.^. TicketId
E.where_ $ td E.^. from E.==. E.val tid
return $ td E.^. TicketDependencyId
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let deps = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length tdids
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems =
map (encodeRouteHome . TicketDepR . encodeHid . E.unValue)
tdids
}
provideHtmlAndAP deps $ redirectToPrettyJSON here
where
here =
let route =
if forward then SharerTicketDepsR else SharerTicketReverseDepsR
in route shr talkhid
getSharerTicketDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketDepsR = getSharerTicketDeps True
getSharerTicketReverseDepsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketReverseDepsR = getSharerTicketDeps False
getSharerTicketFollowersR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
where
here = SharerTicketFollowersR shr talkhid
getFsid = do
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
return $ localTicketFollowers lt
getSharerTicketTeamR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketTeamR shr talkhid = do
_ <- runDB $ getSharerTicket shr talkhid
encodeRouteLocal <- getEncodeRouteLocal
let team = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just 0
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = [] :: [Text]
}
provideHtmlAndAP team $ redirectToPrettyJSON here
where
here = SharerTicketTeamR shr talkhid
getSharerTicketEventsR
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
getSharerTicketEventsR shr talkhid = do
_ <- runDB $ getSharerTicket shr talkhid
encodeRouteLocal <- getEncodeRouteLocal
let team = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeOrdered
, collectionTotalItems = Just 0
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = [] :: [Text]
}
provideHtmlAndAP team $ redirectToPrettyJSON here
where
here = SharerTicketEventsR shr talkhid