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 @@ $# . Enter the details and click "Submit" to create a new ticket. -

+ ^{widget}