Move postTicketsR to Vervis.Handler.Client & submit Follow activity on success

src/Vervis/Client.hs

@@ -21,12 +21,14 @@ module Vervis.Client
     , followProject
     , followTicket
     , followRepo
+    , offerTicket
     )
 where
 
 import Control.Monad.Trans.Except
 import Database.Persist
 import Data.Text (Text)
+import Text.Blaze.Html (preEscapedToHtml)
 import Text.Blaze.Html.Renderer.Text
 import Text.Hamlet
 import Yesod.Core
@@ -193,3 +195,50 @@ followRepo shrAuthor shrObject rpObject hide = do
     encodeRouteHome <- getEncodeRouteHome
     let uObject = encodeRouteHome $ RepoR shrObject rpObject
     follow shrAuthor uObject uObject hide
+
+offerTicket
+    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
+    => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, Offer URIMode))
+offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    descHtml <- ExceptT . pure $ renderPandocMarkdown desc
+    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
+            }
+        offer = Offer
+            { offerObject = ticket
+            , offerTarget = encodeRouteHome $ ProjectR shr prj
+            }
+        audience = Audience
+            { audienceTo        = map encodeRouteHome $ recipsA ++ recipsC
+            , audienceBto       = []
+            , audienceCc        = []
+            , audienceBcc       = []
+            , audienceGeneral   = []
+            , audienceNonActors = map encodeRouteHome recipsC
+            }
+    return (summary, audience, offer)

src/Vervis/Handler/Client.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -22,6 +22,7 @@ module Vervis.Handler.Client
     , postRepoFollowR
     , getNotificationsR
     , postNotificationsR
+    , postTicketsR
     )
 where
 
@@ -68,6 +69,7 @@ import Vervis.ActivityPub
 import Vervis.API
 import Vervis.Client
 import Vervis.FedURI
+import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -526,3 +528,65 @@ postNotificationsR shr = do
         case requireEither mx my of
             Left b    -> liftIO $ throwIO $ userError $ if b then t else f
             Right exy -> return exy
+
+postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
+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
+
+    shrAuthor <- do
+        Entity _ p <- requireVerifiedAuth
+        runDB $ sharerIdent <$> getJust (personIdent p)
+
+    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
+            -}
+        (summary, audience, offer) <-
+            ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
+        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
+            eobiidFollow <- runExceptT $ do
+                (summary, audience, follow) <- followTicket shrAuthor shr prj num False
+                ExceptT $ followC shrAuthor summary audience follow
+            case eobiidFollow of
+                Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e
+                Right _ -> setMessage "Ticket created."
+            redirect $ TicketR shr prj num

src/Vervis/Handler/Ticket.hs

@@ -15,7 +15,6 @@
 
 module Vervis.Handler.Ticket
     ( getTicketsR
-    , postTicketsR
     , getTicketTreeR
     , getTicketNewR
     , getTicketR
@@ -144,100 +143,6 @@ getTicketsR shr prj = do
             jid
     defaultLayout $(widgetFile "ticket/list")
 
-postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
-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
-                }
-            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 shr prj num
-
 getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
 getTicketTreeR shr prj = do
     (summaries, deps) <- runDB $ do