Bring back postTicketsR, now implemented using offerTicketC
This commit is contained in:
fr33domlover
parent
55fdb5437c
commit
4be444f5ab
3 changed files with 102 additions and 63 deletions
|
|
@ -110,7 +110,7 @@ newTicketForm wid html = do
|
|||
[]
|
||||
return (tfs, efs)
|
||||
flip renderDivs html $ NewTicket
|
||||
<$> areq textField "Title*" Nothing
|
||||
<$> (sanitizeBalance <$> areq textField "Title*" Nothing)
|
||||
<*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
|
||||
aopt textareaField "Description (Markdown)" Nothing
|
||||
)
|
||||
|
|
|
|||
|
|
@ -55,8 +55,10 @@ module Vervis.Handler.Ticket
|
|||
where
|
||||
|
||||
import Control.Applicative (liftA2)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger (logWarn)
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bifunctor
|
||||
import Data.Bool (bool)
|
||||
import Data.Default.Class (def)
|
||||
|
|
@ -70,7 +72,7 @@ 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 (Html, toHtml, preEscapedToHtml)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.HTML.SanitizeXSS
|
||||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||||
|
|
@ -90,6 +92,7 @@ import Data.Aeson.Encode.Pretty.ToEncoding
|
|||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Ticket (..))
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
|
||||
|
|
@ -141,43 +144,22 @@ getTicketsR shr prj = do
|
|||
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
|
||||
postTicketsR shr prj = do
|
||||
wid <- runDB $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
j <- getValBy404 $ UniqueProject prj sid
|
||||
return $ projectWorkflow j
|
||||
((result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||||
enum <- runExceptT $ do
|
||||
NewTicket title desc tparams eparams <-
|
||||
case result of
|
||||
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
|
||||
, ticketTitle = sanitizeBalance $ ntTitle nt
|
||||
, ticketSource = source
|
||||
, ticketDescription = descHtml
|
||||
, ticketAssignee = Nothing
|
||||
, ticketStatus = TSNew
|
||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
||||
, ticketCloser = Nothing
|
||||
, ticketDiscuss = did
|
||||
, ticketFollowers = fsid
|
||||
}
|
||||
tid <- insert ticket
|
||||
insert_ $ TicketAuthorLocal tid author $ error "TODO offer"
|
||||
FormMissing -> throwE "Field(s) missing."
|
||||
FormFailure _l ->
|
||||
throwE "Ticket submission failed, see errors below."
|
||||
FormSuccess nt -> return nt
|
||||
unless (null tparams && null eparams) $
|
||||
throwE "Custom param support currently disabled"
|
||||
{-
|
||||
let mktparam (fid, v) = TicketParamText
|
||||
{ ticketParamTextTicket = tid
|
||||
, ticketParamTextField = fid
|
||||
|
|
@ -190,15 +172,72 @@ postTicketsR shar proj = do
|
|||
, ticketParamEnumValue = v
|
||||
}
|
||||
insertMany_ $ map mkeparam $ ntEParams nt
|
||||
return $ ticketNumber ticket
|
||||
-}
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||
shrAuthor <- do
|
||||
Entity _ p <- requireVerifiedAuth
|
||||
lift $ runDB $ sharerIdent <$> getJust (personIdent p)
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{SharerR shrAuthor}>
|
||||
#{shr2text shrAuthor}
|
||||
\ offered a ticket to project #
|
||||
<a href=@{ProjectR shr prj}>
|
||||
./s/#{shr2text shr}/p/#{prj2text prj}
|
||||
: #{preEscapedToHtml title}.
|
||||
|]
|
||||
let recipsA = [ProjectR shr prj]
|
||||
recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
|
||||
ticket = AP.Ticket
|
||||
{ AP.ticketLocal = Nothing
|
||||
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
|
||||
, AP.ticketPublished = Nothing
|
||||
, AP.ticketUpdated = Nothing
|
||||
, AP.ticketName = Nothing
|
||||
, AP.ticketSummary = TextHtml title
|
||||
, AP.ticketContent = TextHtml descHtml
|
||||
, AP.ticketSource = TextPandocMarkdown desc
|
||||
, AP.ticketAssignedTo = Nothing
|
||||
, AP.ticketIsResolved = False
|
||||
, AP.ticketDependsOn = []
|
||||
, AP.ticketDependedBy = []
|
||||
}
|
||||
offer = Offer
|
||||
{ offerObject = ticket
|
||||
, offerTarget = encodeRouteHome $ ProjectR shr prj
|
||||
}
|
||||
audience = Audience
|
||||
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC
|
||||
, audienceBto = []
|
||||
, audienceCc = []
|
||||
, audienceBcc = []
|
||||
, audienceGeneral = []
|
||||
, audienceNonActors = map encodeRouteHome recipsC
|
||||
}
|
||||
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
|
||||
ExceptT $ runDB $ do
|
||||
mtal <- getValBy $ UniqueTicketAuthorLocalOffer obiid
|
||||
case mtal of
|
||||
Nothing ->
|
||||
return $
|
||||
Left
|
||||
"Offer processed successfully but no ticket \
|
||||
\created"
|
||||
Just tal ->
|
||||
Right . ticketNumber <$>
|
||||
getJust (ticketAuthorLocalTicket tal)
|
||||
case enum of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
defaultLayout $(widgetFile "ticket/new")
|
||||
Right num -> do
|
||||
setMessage "Ticket created."
|
||||
redirect $ TicketR 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")
|
||||
redirect $ TicketR shr prj num
|
||||
|
||||
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
getTicketTreeR shr prj = do
|
||||
|
|
@ -211,10 +250,10 @@ getTicketTreeR shr prj = do
|
|||
defaultLayout $ ticketTreeDW shr prj summaries deps
|
||||
|
||||
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
|
||||
getTicketNewR shar proj = do
|
||||
getTicketNewR shr prj = do
|
||||
wid <- runDB $ do
|
||||
Entity sid _ <- getBy404 $ UniqueSharer shar
|
||||
Entity _ j <- getBy404 $ UniqueProject proj sid
|
||||
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||||
Entity _ j <- getBy404 $ UniqueProject prj sid
|
||||
return $ projectWorkflow j
|
||||
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||||
defaultLayout $(widgetFile "ticket/new")
|
||||
|
|
|
|||
|
|
@ -14,6 +14,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
|
||||
Enter the details and click "Submit" to create a new ticket.
|
||||
|
||||
<form method=POST action=@{TicketsR shar proj} enctype=#{enctype}>
|
||||
<form method=POST action=@{TicketsR shr prj} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<input type=submit>
|
||||
|
|
|
|||
Loading…
Reference in a new issue