forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Bring back postTicketsR, now implemented using offerTicketC

Browse source
This commit is contained in:
fr33domlover 2019-06-23 10:00:11 +00:00
parent 55fdb5437c
commit 4be444f5ab
3 changed files with 102 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Vervis/Form/Ticket.hs
View file

@ -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
)

161
src/Vervis/Handler/Ticket.hs
View file

@ -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,64 +144,100 @@ 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
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"
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
postTicketsR shr prj = do
wid <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid
return $ projectWorkflow j
((result, widget), enctype) <- runFormPost $ newTicketForm wid
enum <- runExceptT $ do
NewTicket title desc tparams eparams <-
case result of
FormMissing -> throwE "Field(s) missing."
FormFailure _l ->
throwE "Ticket submission failed, see errors below."
FormSuccess nt -> return nt
unless (null tparams && null eparams) $
throwE "Custom param support currently disabled"
{-
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
, ticketParamTextValue = v
}
insertMany_ $ map mktparam $ ntTParams nt
let mkeparam (fid, v) = TicketParamEnum
{ ticketParamEnumTicket = tid
, ticketParamEnumField = fid
, ticketParamEnumValue = v
}
insertMany_ $ map mkeparam $ ntEParams nt
-}
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
shrAuthor <- do
Entity _ p <- requireVerifiedAuth
lift $ runDB $ sharerIdent <$> getJust (personIdent p)
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ offered a ticket to project #
<a href=@{ProjectR shr prj}>
./s/#{shr2text shr}/p/#{prj2text prj}
: #{preEscapedToHtml title}.
|]
let recipsA = [ProjectR shr prj]
recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
ticket = AP.Ticket
{ AP.ticketLocal = Nothing
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing
, AP.ticketName = Nothing
, AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml
, AP.ticketSource = TextPandocMarkdown desc
, AP.ticketAssignedTo = Nothing
, AP.ticketIsResolved = False
, AP.ticketDependsOn = []
, AP.ticketDependedBy = []
}
offer = Offer
{ offerObject = ticket
, offerTarget = encodeRouteHome $ ProjectR shr prj
}
audience = Audience
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC
, audienceBto = []
, audienceCc = []
, audienceBcc = []
, audienceGeneral = []
, audienceNonActors = map encodeRouteHome recipsC
}
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
ExceptT $ runDB $ do
mtal <- getValBy $ UniqueTicketAuthorLocalOffer obiid
case mtal of
Nothing ->
return $
Left
"Offer processed successfully but no ticket \
\created"
Just tal ->
Right . ticketNumber <$>
getJust (ticketAuthorLocalTicket tal)
case enum of
Left e -> do
setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new")
Right num -> do
setMessage "Ticket created."
redirect $ TicketR 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")

2
templates/ticket/new.hamlet
View file

@ -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>