diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 6bde33a..45fca46 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -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 ) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 18cedc8..db5ac40 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -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| +
+
+ #{shr2text shrAuthor}
+ \ offered a ticket to project #
+
+ ./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")
diff --git a/templates/ticket/new.hamlet b/templates/ticket/new.hamlet
index f1105fd..5e0885e 100644
--- a/templates/ticket/new.hamlet
+++ b/templates/ticket/new.hamlet
@@ -14,6 +14,6 @@ $#