Bring back postTicketsR, now implemented using offerTicketC

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
             )

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
+postTicketsR shr prj = do
-    Entity pid project <- runDB $ do
+    wid <- runDB $ do
-        Entity sid _sharer <- getBy404 $ UniqueSharer shar
+        sid <- getKeyBy404 $ UniqueSharer shr
-        getBy404 $ UniqueProject proj sid
+        j <- getValBy404 $ UniqueProject prj sid
-    ((result, widget), enctype) <-
+        return $ projectWorkflow j
-        runFormPost $ newTicketForm $ projectWorkflow project
+    ((result, widget), enctype) <- runFormPost $ newTicketForm wid
-    case result of
+    enum <- runExceptT $ do
-        FormSuccess nt -> do
+        NewTicket title desc tparams eparams <-
-            author <- requireAuthId
+            case result of
-            now <- liftIO getCurrentTime
+                FormMissing -> throwE "Field(s) missing."
-            let source = ntDesc nt
+                FormFailure _l ->
-            descHtml <-
+                    throwE "Ticket submission failed, see errors below."
-                case renderPandocMarkdown source of
+                FormSuccess nt -> return nt
-                    Left err -> do
+        unless (null tparams && null eparams) $
-                        setMessage $ toHtml err
+            throwE "Custom param support currently disabled"
-                        redirect $ TicketNewR shar proj
+            {-
-                    Right t -> return t
+            let mktparam (fid, v) = TicketParamText
-            tnum <- runDB $ do
+                    { ticketParamTextTicket = tid
-                update pid [ProjectNextTicket +=. 1]
+                    , ticketParamTextField  = fid
-                did <- insert Discussion
+                    , ticketParamTextValue  = v
-                fsid <- insert FollowerSet
+                    }
-                let ticket = Ticket
+            insertMany_ $ map mktparam $ ntTParams nt
-                        { ticketProject     = pid
+            let mkeparam (fid, v) = TicketParamEnum
-                        , ticketNumber      = projectNextTicket project
+                    { ticketParamEnumTicket = tid
-                        , ticketCreated     = now
+                    , ticketParamEnumField  = fid
-                        , ticketTitle       = sanitizeBalance $ ntTitle nt
+                    , ticketParamEnumValue  = v
-                        , ticketSource      = source
+                    }
-                        , ticketDescription = descHtml
+            insertMany_ $ map mkeparam $ ntEParams nt
-                        , ticketAssignee    = Nothing
+            -}
-                        , ticketStatus      = TSNew
+        encodeRouteLocal <- getEncodeRouteLocal
-                        , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
+        encodeRouteHome <- getEncodeRouteHome
-                        , ticketCloser      = Nothing
+        descHtml <- ExceptT . pure $ renderPandocMarkdown desc
-                        , ticketDiscuss     = did
+        shrAuthor <- do
-                        , ticketFollowers   = fsid
+            Entity _ p <- requireVerifiedAuth
-                        }
+            lift $ runDB $ sharerIdent <$> getJust (personIdent p)
-                tid <- insert ticket
+        summary <-
-                insert_ $ TicketAuthorLocal tid author $ error "TODO offer"
+            TextHtml . TL.toStrict . renderHtml <$>
-                let mktparam (fid, v) = TicketParamText
+                withUrlRenderer
-                        { ticketParamTextTicket = tid
+                    [hamlet|
-                        , ticketParamTextField  = fid
+                        <p>
-                        , ticketParamTextValue  = v
+                          <a href=@{SharerR shrAuthor}>
-                        }
+                            #{shr2text shrAuthor}
-                insertMany_ $ map mktparam $ ntTParams nt
+                          \ offered a ticket to project #
-                let mkeparam (fid, v) = TicketParamEnum
+                          <a href=@{ProjectR shr prj}>
-                        { ticketParamEnumTicket = tid
+                            ./s/#{shr2text shr}/p/#{prj2text prj}
-                        , ticketParamEnumField  = fid
+                          : #{preEscapedToHtml title}.
-                        , ticketParamEnumValue  = v
+                    |]
-                        }
+        let recipsA = [ProjectR shr prj]
-                insertMany_ $ map mkeparam $ ntEParams nt
+            recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
-                return $ ticketNumber ticket
+            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
+            redirect $ TicketR shr prj num
-        FormMissing -> do
-            setMessage "Field(s) missing."
-            defaultLayout $(widgetFile "ticket/new")
-        FormFailure _l -> do
-            setMessage "Ticket creation failed, see errors below."
-            defaultLayout $(widgetFile "ticket/new")
 
 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 sid _ <- getBy404 $ UniqueSharer shr
-        Entity _   j <- getBy404 $ UniqueProject proj sid
+        Entity _   j <- getBy404 $ UniqueProject prj sid
         return $ projectWorkflow j
     ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
     defaultLayout $(widgetFile "ticket/new")

templates/ticket/new.hamlet

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