Client, UI: Git merge request submission form

2024-12-27 02:34:51 +09:00 · 2022-09-23 05:20:39 +00:00 · 2022-09-23 05:20:39 +00:00 · 0d922b0e5a
commit 0d922b0e5a
parent 9cb90c58c0
12 changed files with 394 additions and 60 deletions
--- a/src/Vervis/Client.hs
+++ b/src/Vervis/Client.hs
@ -28,16 +28,19 @@ module Vervis.Client
    --, undoFollowTicket
    --, undoFollowRepo
    --, unresolve
-    --, offerMR
-      createDeck
+      offerPatches
+    , offerMerge
+    , createDeck
    , createLoom
    , createRepo
    )
 where

+import Control.Exception.Base
 import Control.Monad
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
+import Data.Bifunctor
 import Data.Bitraversable
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
@ -51,6 +54,7 @@ import Yesod.Core
 import Yesod.Core.Handler
 import Yesod.Persist.Core

+import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL

@ -62,7 +66,6 @@ import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite
-import Yesod.RenderSource

 import qualified Web.ActivityPub as AP

@ -71,10 +74,12 @@ import Data.Either.Local
 import Database.Persist.Local

 import Vervis.ActivityPub
+import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Recipient
+import Vervis.RemoteActorStore
 import Vervis.Ticket
 import Vervis.WorkItem

@ -529,75 +534,193 @@ unresolve shrUser uTicket = runExceptT $ do
        recips = map encodeRouteHome audLocal ++ audRemote
    return (Nothing, Audience recips [] [] [] [] [], Undo uResolve)
    -}
+-}

-offerMR
-    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent
-    -> TextHtml
-    -> TextPandocMarkdown
-    -> FedURI
-    -> Maybe FedURI
-    -> PatchMediaType
+offerPatches
+    :: KeyHashid Person
    -> Text
-    -> m (Either Text (Maybe TextHtml, Audience URIMode, AP.Ticket URIMode))
-offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do
-    error "Temporarily disabled"
-    {-
+    -> PandocMarkdown
+    -> FedURI
+    -> FedURI
+    -> Maybe Text
+    -> PatchMediaType
+    -> NonEmpty Text
+    -> ExceptT Text Handler (Maybe HTML, AP.Audience URIMode, AP.Ticket URIMode)
+offerPatches senderHash title desc uTracker uTargetRepo maybeBranch typ diffs = do
+
+    tracker <- do
+        tracker <- checkTracker uTracker
+        case tracker of
+            TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
+            TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
+            TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
+                instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
+                result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
+                case result of
+                    Left Nothing -> throwE "Tracker @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Tracker isn't an actor"
+                    Right (Just actor) -> return (entityVal actor, uTracker)
+
+    descHtml <- ExceptT . pure $ renderPandocMarkdown desc
+
    encodeRouteLocal <- getEncodeRouteLocal
    encodeRouteHome <- getEncodeRouteHome
-    manager <- asksSite appHttpManager
    hLocal <- asksSite siteInstanceHost

-    context <- parseTicketContext uContext
-    descHtml <-
-        ExceptT . pure $ renderPandocMarkdown $ unTextPandocMarkdown desc
-    context' <- bitraverse pure (getRemoteContextHttp "Context") context
-
    let audAuthor =
-            AudLocal
-                []
-                [LocalPersonCollectionSharerFollowers shrAuthor]
-        audContext = contextAudience context'
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+        audTracker =
+            case tracker of
+                Left loomHash ->
+                    AudLocal
+                        [LocalActorLoom loomHash]
+                        [LocalStageLoomFollowers loomHash]
+                Right (remoteActor, ObjURI hTracker luTracker) ->
+                    AudRemote hTracker
+                        [luTracker]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+

        (_, _, _, audLocal, audRemote) =
-            collectAudience $ audAuthor : audContext
-
+            collectAudience [audAuthor, audTracker]
        recips = map encodeRouteHome audLocal ++ audRemote
-        ObjURI hBranch luBranch = fromMaybe uContext muBranch
-        luAuthor = encodeRouteLocal $ SharerR shrAuthor

+        luSender = encodeRouteLocal $ PersonR senderHash
+        ObjURI hTargetRepo luTargetRepo = uTargetRepo
        ticket = AP.Ticket
            { AP.ticketLocal        = Nothing
-            , AP.ticketAttributedTo = luAuthor
+            , AP.ticketAttributedTo = luSender
            , AP.ticketPublished    = Nothing
            , AP.ticketUpdated      = Nothing
            , AP.ticketContext      = Nothing
-            , AP.ticketSummary      = title
-            , AP.ticketContent      = TextHtml descHtml
+            , AP.ticketSummary      = encodeEntities title
+            , AP.ticketContent      = descHtml
            , AP.ticketSource       = desc
            , AP.ticketAssignedTo   = Nothing
            , AP.ticketResolved     = Nothing
            , AP.ticketAttachment   = Just
-                ( hBranch
+                ( hTargetRepo
                , MergeRequest
                    { mrOrigin = Nothing
-                    , mrTarget = luBranch
-                    , mrBundle = Right
+                    , mrTarget =
+                        case maybeBranch of
+                            Nothing -> Left luTargetRepo
+                            Just b -> Right AP.Branch
+                                { AP.branchName = b
+                                , AP.branchRef  = "refs/heads/" <> b
+                                , AP.branchRepo = luTargetRepo
+                                }
+                    , mrBundle = Just $ Right
                        ( hLocal
-                        , BundleOffer Nothing $ pure AP.Patch
-                            { AP.patchLocal        = Nothing
-                            , AP.patchAttributedTo = luAuthor
-                            , AP.patchPublished    = Nothing
-                            , AP.patchType         = typ
-                            , AP.patchContent      = diff
-                            }
+                        , BundleOffer Nothing $ NE.reverse $ NE.map
+                            (\ diff -> AP.Patch
+                                { AP.patchLocal        = Nothing
+                                , AP.patchAttributedTo = luSender
+                                , AP.patchPublished    = Nothing
+                                , AP.patchType         = typ
+                                , AP.patchContent      = diff
+                                }
+                            )
+                            diffs
                        )
                    }
                )
            }
-    return (Nothing, Audience recips [] [] [] [] [], ticket)
-    -}
-}
+
+    return (Nothing, AP.Audience recips [] [] [] [] [], ticket)
+
+offerMerge
+    :: KeyHashid Person
+    -> Text
+    -> PandocMarkdown
+    -> FedURI
+    -> FedURI
+    -> Maybe Text
+    -> FedURI
+    -> Maybe Text
+    -> ExceptT Text Handler (Maybe HTML, AP.Audience URIMode, AP.Ticket URIMode)
+offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginRepo maybeOriginBranch = do
+
+    tracker <- do
+        tracker <- checkTracker uTracker
+        case tracker of
+            TrackerDeck _ -> throwE "Local ticket tracker doesn't take patches"
+            TrackerLoom loomID -> Left <$> encodeKeyHashid loomID
+            TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
+                instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
+                result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
+                case result of
+                    Left Nothing -> throwE "Tracker @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Tracker isn't an actor"
+                    Right (Just actor) -> return (entityVal actor, uTracker)
+
+    descHtml <- ExceptT . pure $ renderPandocMarkdown desc
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hLocal <- asksSite siteInstanceHost
+
+    let audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+        audTracker =
+            case tracker of
+                Left loomHash ->
+                    AudLocal
+                        [LocalActorLoom loomHash]
+                        [LocalStageLoomFollowers loomHash]
+                Right (remoteActor, ObjURI hTracker luTracker) ->
+                    AudRemote hTracker
+                        [luTracker]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+
+
+        (_, _, _, audLocal, audRemote) =
+            collectAudience [audAuthor, audTracker]
+        recips = map encodeRouteHome audLocal ++ audRemote
+
+        ObjURI hTargetRepo luTargetRepo = uTargetRepo
+        ObjURI hOriginRepo luOriginRepo = uOriginRepo
+        ticket = AP.Ticket
+            { AP.ticketLocal        = Nothing
+            , AP.ticketAttributedTo = encodeRouteLocal $ PersonR senderHash
+            , AP.ticketPublished    = Nothing
+            , AP.ticketUpdated      = Nothing
+            , AP.ticketContext      = Nothing
+            , AP.ticketSummary      = encodeEntities title
+            , AP.ticketContent      = descHtml
+            , AP.ticketSource       = desc
+            , AP.ticketAssignedTo   = Nothing
+            , AP.ticketResolved     = Nothing
+            , AP.ticketAttachment   = Just
+                ( hTargetRepo
+                , MergeRequest
+                    { mrOrigin =
+                        Just $ case maybeOriginBranch of
+                            Nothing -> Left uOriginRepo
+                            Just b -> Right
+                                ( hOriginRepo
+                                , AP.Branch
+                                    { AP.branchName = b
+                                    , AP.branchRef  = "refs/heads/" <> b
+                                    , AP.branchRepo = luOriginRepo
+                                    }
+                                )
+                    , mrTarget =
+                        case maybeTargetBranch of
+                            Nothing -> Left luTargetRepo
+                            Just b -> Right AP.Branch
+                                { AP.branchName = b
+                                , AP.branchRef  = "refs/heads/" <> b
+                                , AP.branchRepo = luTargetRepo
+                                }
+                    , mrBundle = Nothing
+                    }
+                )
+            }
+
+    return (Nothing, AP.Audience recips [] [] [] [] [], ticket)

 createDeck
    :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
--- a/src/Vervis/Data/Ticket.hs
+++ b/src/Vervis/Data/Ticket.hs
@ -20,6 +20,10 @@ module Vervis.Data.Ticket
    , TrackerAndMerge (..)
    , WorkItemOffer (..)
    , checkOfferTicket
+
+    -- These are exported only for Vervis.Client
+    , Tracker (..)
+    , checkTracker
    )
 where

--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@ -308,8 +308,8 @@ instance Yesod App where

        -- Client

-        (NotificationsR, _   ) -> personAny
-        (PublishR      , True) -> personAny
+        (NotificationsR,     _   ) -> personAny
+        (PublishOfferMergeR, True) -> personAny

        -- Person

--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@ -26,6 +26,9 @@ module Vervis.Handler.Client
    , getPublishR
    , postPublishR
    , getInboxDebugR
+
+    , getPublishOfferMergeR
+    , postPublishOfferMergeR
    )
 where

@ -64,23 +67,28 @@ import Dvara

 import Database.Persist.JSON
 import Network.FedURI
+import Web.Text
 import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 import Yesod.RenderSource

 import qualified Web.ActivityPub as AP

+import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Data.EventTime.Local
 import Data.Time.Clock.Local
 import Database.Persist.Local
+import Yesod.Form.Local
 import Yesod.Persist.Local

 import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.API
+import Vervis.Client
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
@ -1010,3 +1018,127 @@ postProjectTicketOpenR shr prj ltkhid = do
        Right _obiid -> setMessage "Ticket reopened"
    redirect $ ProjectTicketR shr prj ltkhid
 -}
+
+fedUriField
+    :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
+fedUriField = Field
+    { fieldParse = parseHelper $ \ t ->
+        case parseObjURI t of
+            Left e  -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
+            Right u -> Right u
+    , fieldView = \theId name attrs val isReq ->
+        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
+    , fieldEnctype = UrlEncoded
+    }
+
+getSender :: Handler (Entity Person, Actor)
+getSender = do
+    ep@(Entity _ p) <- requireAuth
+    a <- runDB $ getJust $ personActor p
+    return (ep, a)
+
+data OfferMergeGit = OfferMergeGit
+    { omgTracker      :: FedURI
+    , omgTargetRepo   :: FedURI
+    , omgTargetBranch :: Text
+    , omgOriginRepo   :: FedURI
+    , omgOriginBranch :: Text
+    , omgTitle        :: Text
+    , omgDesc         :: PandocMarkdown
+    }
+
+offerMergeGitForm :: Form OfferMergeGit
+offerMergeGitForm = renderDivs $ OfferMergeGit
+    <$> areq fedUriField "Patch tracker URL"                Nothing
+    <*> areq fedUriField "Target repo URL"                  Nothing
+    <*> areq textField   "Target branch (e.g. main)"        Nothing
+    <*> areq fedUriField "Origin repo URL"                  Nothing
+    <*> areq textField   "Origin branch (e.g. fix-the-bug)" Nothing
+    <*> areq textField   "Title"                            Nothing
+    <*> (pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$>
+            areq textareaField "Description" Nothing
+        )
+
+{-
+data OfferMergeGit = OfferMergeGit
+    { omgTracker :: FedURI
+    , omgTarget  :: (FedURI, Text)
+    , omgOrigin  :: (FedURI, Text)
+    , omgTitle   :: Text
+    , omgDesc    :: PandocMarkdown
+    PatchMediaType
+    FileInfo
+-}
+
+{-
+offerMergeForm :: Form (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo)
+offerMergeForm = renderDivs $ (,,,,,)
+    <$> areq fedUriField "Repo" (Just defaultRepo)
+    <*> aopt fedUriField "Branch URI (for Git repos)" Nothing
+    <*> (TextHtml . sanitizeBalance <$> areq textField "Title" Nothing)
+    <*> (TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$>
+            areq textareaField "Description" Nothing
+        )
+    <*> areq (selectFieldList pmtList) "Type" Nothing
+    <*> areq fileField "Patch" Nothing
+    where
+    defaultRepo =
+        ObjURI
+            (Authority "forge.angeley.es" Nothing)
+            (LocalURI "/s/fr33/r/one-more-darcs")
+    pmtList :: [(Text, PatchMediaType)]
+    pmtList =
+        [ ("Darcs", PatchMediaTypeDarcs)
+        ]
+-}
+
+getPublishOfferMergeR :: Handler Html
+getPublishOfferMergeR = do
+    ((_, widget), enctype) <- runFormPost offerMergeGitForm
+    defaultLayout
+        [whamlet|
+            <h1>Open a Merge Request on a Git repo
+            <form method=POST action=@{PublishOfferMergeR} enctype=#{enctype}>
+              ^{widget}
+              <input type=submit>
+        |]
+
+postPublishOfferMergeR :: Handler ()
+postPublishOfferMergeR = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+
+    OfferMergeGit {..} <-
+        runFormPostRedirect PublishOfferMergeR offerMergeGitForm
+
+    (ep@(Entity pid _), a) <- getSender
+    senderHash <- encodeKeyHashid pid
+
+    trackerLocal <- hostIsLocal $ objUriAuthority omgTracker
+    edest <- runExceptT $ do
+        (summary, audience, ticket) <-
+            offerMerge
+                senderHash omgTitle omgDesc omgTracker
+                omgTargetRepo (Just omgTargetBranch)
+                omgOriginRepo (Just omgOriginBranch)
+        offerID <- offerTicketC ep a summary audience ticket omgTracker
+        if trackerLocal
+            then nameExceptT "Offer published but" $ runDBExcept $ do
+                ticketID <- do
+                    mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
+                    ticketAuthorLocalTicket <$>
+                        fromMaybeE mtal "Can't find the ticket in DB"
+                Entity clothID cloth <- do
+                    mtl <- lift $ getBy $ UniqueTicketLoom ticketID
+                    fromMaybeE mtl "Can't find ticket's patch tracker in DB"
+                ClothR <$> encodeKeyHashid (ticketLoomLoom cloth) <*> encodeKeyHashid clothID
+            else PersonOutboxItemR senderHash <$> encodeKeyHashid offerID
+    case edest of
+        Left err -> do
+            setMessage $ toHtml err
+            redirect PublishOfferMergeR
+        Right dest -> do
+            if trackerLocal
+                then setMessage "Merge Request created"
+                else setMessage "Offer published"
+            redirect dest
--- a/src/Vervis/Handler/Deck.hs
+++ b/src/Vervis/Handler/Deck.hs
@ -310,8 +310,7 @@ getDeckNewR = do

 postDeckNewR :: Handler Html
 postDeckNewR = do
-    (NewProject name desc, _widget, _enctype) <-
-        runFormPostRedirect DeckNewR newProjectForm
+    NewProject name desc <- runFormPostRedirect DeckNewR newProjectForm

    personEntity@(Entity personID person) <- requireAuth
    personHash <- encodeKeyHashid personID
--- a/src/Vervis/Handler/Loom.hs
+++ b/src/Vervis/Handler/Loom.hs
@ -247,8 +247,7 @@ getLoomNewR = do

 postLoomNewR :: Handler Html
 postLoomNewR = do
-    (NewLoom name desc repoID, _widget, _enctype) <-
-        runFormPostRedirect LoomNewR newLoomForm
+    NewLoom name desc repoID <- runFormPostRedirect LoomNewR newLoomForm

    personEntity@(Entity personID person) <- requireAuth
    personHash <- encodeKeyHashid personID
--- a/src/Vervis/Handler/Repo.hs
+++ b/src/Vervis/Handler/Repo.hs
@ -427,8 +427,7 @@ getRepoNewR = do

 postRepoNewR :: Handler Html
 postRepoNewR = do
-    (NewRepo name desc vcs, _widget, _enctype) <-
-        runFormPostRedirect RepoNewR newRepoForm
+    NewRepo name desc vcs <- runFormPostRedirect RepoNewR newRepoForm

    personEntity@(Entity personID person) <- requireAuth
    personHash <- encodeKeyHashid personID
--- a/src/Web/Text.hs
+++ b/src/Web/Text.hs
@ -1,6 +1,6 @@
 {- This file is part of Vervis.
 -
- - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
@ -19,12 +19,16 @@ module Web.Text
    , Escaped ()
    , renderHTML
    , markupHTML
+    , renderPandocMarkdown
+    , pandocMarkdownFromText
    , encodeEntities
    , decodeEntities
    )
 where

+import Control.Exception
 import Data.Aeson
+import Data.Bifunctor
 import Data.Text (Text)
 import Database.Persist
 import Database.Persist.Sql
@ -33,7 +37,13 @@ import Text.Blaze (preEscapedText)
 import Text.Blaze.Html (Html)
 import Text.Blaze.Html.Renderer.Text
 import Text.HTML.SanitizeXSS
+import Text.Pandoc.Class (runPure)
+import Text.Pandoc.Highlighting
+import Text.Pandoc.Options
+import Text.Pandoc.Readers.Markdown
+import Text.Pandoc.Writers.HTML

+import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TLB
 import qualified HTMLEntities.Text as HET
@ -70,6 +80,66 @@ renderHTML = HTML . TL.toStrict . renderHtml
 markupHTML :: HTML -> Html
 markupHTML = preEscapedText . unHTML

+readerOptions :: ReaderOptions
+readerOptions = def
+    { readerExtensions            = pandocExtensions
+    , readerStandalone            = False
+    , readerColumns               = 80
+    , readerTabStop               = 4
+--  , readerIndentedCodeClasses   = []
+--  , readerAbbreviations         = defaultAbbrevs
+--  , readerDefaultImageExtension = ""
+--  , readerTrackChanges          = AcceptChanges
+--  , readerStripComments         = False
+    }
+
+writerOptions :: WriterOptions
+writerOptions = def
+    {
+--    writerTemplate          = Nothing
+--  , writerVariables         = []
+      writerTabStop           = 4
+    , writerTableOfContents   = True
+--  , writerIncremental       = False
+--  , writerHTMLMathMethod    = PlainMath
+--  , writerNumberSections    = False
+--  , writerNumberOffset      = [0,0,0,0,0,0]
+--  , writerSectionDivs       = False
+    , writerExtensions        = pandocExtensions
+--  , writerReferenceLinks    = False
+--  , writerDpi               = 96
+    , writerWrapText          = WrapAuto
+    , writerColumns           = 79
+    , writerEmailObfuscation  = ReferenceObfuscation
+--  , writerIdentifierPrefix  = ""
+--  , writerCiteMethod        = Citeproc
+--  , writerHtmlQTags         = False
+--  , writerSlideLevel        = Nothing
+--  , writerTopLevelDivision  = TopLevelDefault
+--  , writerListings          = False
+    , writerHighlightStyle    = Just tango
+--  , writerSetextHeaders     = True
+--  , writerEpubSubdirectory  = "EPUB"
+--  , writerEpubMetadata      = Nothing
+--  , writerEpubFonts         = []
+--  , writerEpubChapterLevel  = 1
+--  , writerTOCDepth          = 3
+--  , writerReferenceDoc      = Nothing
+--  , writerReferenceLocation = EndOfDocument
+--  , writerSyntaxMap         = defaultSyntaxMap
+    }
+
+renderPandocMarkdown :: PandocMarkdown -> Either Text HTML
+renderPandocMarkdown (PandocMarkdown input) = do
+    doc <- runPure' $ readMarkdown readerOptions input
+    HTML . sanitizeBalance . TL.toStrict . renderHtml <$>
+        runPure' (writeHtml5 writerOptions doc)
+    where
+    runPure' = first (T.pack . displayException) . runPure
+
+pandocMarkdownFromText :: Text -> PandocMarkdown
+pandocMarkdownFromText = PandocMarkdown
+
 encodeEntities :: Text -> Escaped
 encodeEntities = Escaped . escape

--- a/src/Yesod/Form/Local.hs
+++ b/src/Yesod/Form/Local.hs
@ -22,7 +22,7 @@ import Yesod.Core.Handler
 import Yesod.Form

 runFormPostRedirect here form = do
-    ((result, widget), enctype) <- runFormPost form
+    ((result, _), _) <- runFormPost form
    case result of
        FormMissing -> do
            setMessage "Field(s) missing"
@ -30,4 +30,4 @@ runFormPostRedirect here form = do
        FormFailure _l -> do
            setMessage "Operation failed, see below"
            redirect here
-        FormSuccess v -> return (v, widget, enctype)
+        FormSuccess v -> return v
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@ -39,7 +39,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
          <a href=@{BrowseR}>
            [📚 Browse projects]
        <span>
-          <a href=@{PublishR}>
+          <a href=@{HomeR}>
            [📣 Publish an activity]
        <span>
          <a href=@{AuthR LogoutR}>
--- a/templates/personal-overview.hamlet
+++ b/templates/personal-overview.hamlet
@ -19,8 +19,14 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.

 <ul>
  <li>
+    <a href=@{RepoNewR}>
+      Create a new repository
  <li>
    <a href=@{DeckNewR}>
      Create a new ticket tracker
-    <a href=@{PublishR}>
-      Publish an activity
+  <li>
+    <a href=@{LoomNewR}>
+      Create a new patch tracker
+  <li>
+    <a href=@{PublishOfferMergeR}>
+      Open a merge request
--- a/th/routes
+++ b/th/routes
@ -127,9 +127,11 @@
 /              HomeR          GET
 /browse        BrowseR        GET
 /notifications NotificationsR GET POST
-/publish       PublishR       GET POST
+-- /publish       PublishR       GET POST
 /inbox         InboxDebugR    GET

+/publish/offer-merge PublishOfferMergeR GET POST
+
 ---- Person ------------------------------------------------------------------

 /people/#PersonKeyHashid                                 PersonR           GET