Client, UI: Git merge request submission form

This commit is contained in:
fr33domlover 2022-09-23 05:20:39 +00:00
parent 9cb90c58c0
commit 0d922b0e5a
12 changed files with 394 additions and 60 deletions

View file

@ -28,16 +28,19 @@ module Vervis.Client
--, undoFollowTicket --, undoFollowTicket
--, undoFollowRepo --, undoFollowRepo
--, unresolve --, unresolve
--, offerMR offerPatches
createDeck , offerMerge
, createDeck
, createLoom , createLoom
, createRepo , createRepo
) )
where where
import Control.Exception.Base
import Control.Monad import Control.Monad
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe import Data.Maybe
@ -51,6 +54,7 @@ import Yesod.Core
import Yesod.Core.Handler import Yesod.Core.Handler
import Yesod.Persist.Core import Yesod.Persist.Core
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
@ -62,7 +66,6 @@ import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
import Yesod.RenderSource
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
@ -71,10 +74,12 @@ import Data.Either.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.Data.Ticket
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Recipient import Vervis.Recipient
import Vervis.RemoteActorStore
import Vervis.Ticket import Vervis.Ticket
import Vervis.WorkItem import Vervis.WorkItem
@ -529,75 +534,193 @@ unresolve shrUser uTicket = runExceptT $ do
recips = map encodeRouteHome audLocal ++ audRemote recips = map encodeRouteHome audLocal ++ audRemote
return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) return (Nothing, Audience recips [] [] [] [] [], Undo uResolve)
-} -}
-}
offerMR offerPatches
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: KeyHashid Person
=> ShrIdent
-> TextHtml
-> TextPandocMarkdown
-> FedURI
-> Maybe FedURI
-> PatchMediaType
-> Text -> Text
-> m (Either Text (Maybe TextHtml, Audience URIMode, AP.Ticket URIMode)) -> PandocMarkdown
offerMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do -> FedURI
error "Temporarily disabled" -> 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 encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
manager <- asksSite appHttpManager
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
context <- parseTicketContext uContext
descHtml <-
ExceptT . pure $ renderPandocMarkdown $ unTextPandocMarkdown desc
context' <- bitraverse pure (getRemoteContextHttp "Context") context
let audAuthor = let audAuthor =
AudLocal AudLocal [] [LocalStagePersonFollowers senderHash]
[] audTracker =
[LocalPersonCollectionSharerFollowers shrAuthor] case tracker of
audContext = contextAudience context' Left loomHash ->
AudLocal
[LocalActorLoom loomHash]
[LocalStageLoomFollowers loomHash]
Right (remoteActor, ObjURI hTracker luTracker) ->
AudRemote hTracker
[luTracker]
(maybeToList $ remoteActorFollowers remoteActor)
(_, _, _, audLocal, audRemote) = (_, _, _, audLocal, audRemote) =
collectAudience $ audAuthor : audContext collectAudience [audAuthor, audTracker]
recips = map encodeRouteHome audLocal ++ audRemote 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 ticket = AP.Ticket
{ AP.ticketLocal = Nothing { AP.ticketLocal = Nothing
, AP.ticketAttributedTo = luAuthor , AP.ticketAttributedTo = luSender
, AP.ticketPublished = Nothing , AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing , AP.ticketUpdated = Nothing
, AP.ticketContext = Nothing , AP.ticketContext = Nothing
, AP.ticketSummary = title , AP.ticketSummary = encodeEntities title
, AP.ticketContent = TextHtml descHtml , AP.ticketContent = descHtml
, AP.ticketSource = desc , AP.ticketSource = desc
, AP.ticketAssignedTo = Nothing , AP.ticketAssignedTo = Nothing
, AP.ticketResolved = Nothing , AP.ticketResolved = Nothing
, AP.ticketAttachment = Just , AP.ticketAttachment = Just
( hBranch ( hTargetRepo
, MergeRequest , MergeRequest
{ mrOrigin = Nothing { mrOrigin = Nothing
, mrTarget = luBranch , mrTarget =
, mrBundle = Right 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 ( hLocal
, BundleOffer Nothing $ pure AP.Patch , BundleOffer Nothing $ NE.reverse $ NE.map
{ AP.patchLocal = Nothing (\ diff -> AP.Patch
, AP.patchAttributedTo = luAuthor { AP.patchLocal = Nothing
, AP.patchPublished = Nothing , AP.patchAttributedTo = luSender
, AP.patchType = typ , AP.patchPublished = Nothing
, AP.patchContent = diff , 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 createDeck
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)

View file

@ -20,6 +20,10 @@ module Vervis.Data.Ticket
, TrackerAndMerge (..) , TrackerAndMerge (..)
, WorkItemOffer (..) , WorkItemOffer (..)
, checkOfferTicket , checkOfferTicket
-- These are exported only for Vervis.Client
, Tracker (..)
, checkTracker
) )
where where

View file

@ -308,8 +308,8 @@ instance Yesod App where
-- Client -- Client
(NotificationsR, _ ) -> personAny (NotificationsR, _ ) -> personAny
(PublishR , True) -> personAny (PublishOfferMergeR, True) -> personAny
-- Person -- Person

View file

@ -26,6 +26,9 @@ module Vervis.Handler.Client
, getPublishR , getPublishR
, postPublishR , postPublishR
, getInboxDebugR , getInboxDebugR
, getPublishOfferMergeR
, postPublishOfferMergeR
) )
where where
@ -64,23 +67,28 @@ import Dvara
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.Text
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource import Yesod.RenderSource
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Either.Local import Data.Either.Local
import Data.EventTime.Local import Data.EventTime.Local
import Data.Time.Clock.Local import Data.Time.Clock.Local
import Database.Persist.Local import Database.Persist.Local
import Yesod.Form.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.API import Vervis.API
import Vervis.Client
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
@ -1010,3 +1018,127 @@ postProjectTicketOpenR shr prj ltkhid = do
Right _obiid -> setMessage "Ticket reopened" Right _obiid -> setMessage "Ticket reopened"
redirect $ ProjectTicketR shr prj ltkhid 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

View file

@ -310,8 +310,7 @@ getDeckNewR = do
postDeckNewR :: Handler Html postDeckNewR :: Handler Html
postDeckNewR = do postDeckNewR = do
(NewProject name desc, _widget, _enctype) <- NewProject name desc <- runFormPostRedirect DeckNewR newProjectForm
runFormPostRedirect DeckNewR newProjectForm
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID personHash <- encodeKeyHashid personID

View file

@ -247,8 +247,7 @@ getLoomNewR = do
postLoomNewR :: Handler Html postLoomNewR :: Handler Html
postLoomNewR = do postLoomNewR = do
(NewLoom name desc repoID, _widget, _enctype) <- NewLoom name desc repoID <- runFormPostRedirect LoomNewR newLoomForm
runFormPostRedirect LoomNewR newLoomForm
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID personHash <- encodeKeyHashid personID

View file

@ -427,8 +427,7 @@ getRepoNewR = do
postRepoNewR :: Handler Html postRepoNewR :: Handler Html
postRepoNewR = do postRepoNewR = do
(NewRepo name desc vcs, _widget, _enctype) <- NewRepo name desc vcs <- runFormPostRedirect RepoNewR newRepoForm
runFormPostRedirect RepoNewR newRepoForm
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID personHash <- encodeKeyHashid personID

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - Copying is an act of love. Please copy, reuse and share.
- -
@ -19,12 +19,16 @@ module Web.Text
, Escaped () , Escaped ()
, renderHTML , renderHTML
, markupHTML , markupHTML
, renderPandocMarkdown
, pandocMarkdownFromText
, encodeEntities , encodeEntities
, decodeEntities , decodeEntities
) )
where where
import Control.Exception
import Data.Aeson import Data.Aeson
import Data.Bifunctor
import Data.Text (Text) import Data.Text (Text)
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
@ -33,7 +37,13 @@ import Text.Blaze (preEscapedText)
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Text import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS 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 as TL
import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder as TLB
import qualified HTMLEntities.Text as HET import qualified HTMLEntities.Text as HET
@ -70,6 +80,66 @@ renderHTML = HTML . TL.toStrict . renderHtml
markupHTML :: HTML -> Html markupHTML :: HTML -> Html
markupHTML = preEscapedText . unHTML 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 :: Text -> Escaped
encodeEntities = Escaped . escape encodeEntities = Escaped . escape

View file

@ -22,7 +22,7 @@ import Yesod.Core.Handler
import Yesod.Form import Yesod.Form
runFormPostRedirect here form = do runFormPostRedirect here form = do
((result, widget), enctype) <- runFormPost form ((result, _), _) <- runFormPost form
case result of case result of
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing" setMessage "Field(s) missing"
@ -30,4 +30,4 @@ runFormPostRedirect here form = do
FormFailure _l -> do FormFailure _l -> do
setMessage "Operation failed, see below" setMessage "Operation failed, see below"
redirect here redirect here
FormSuccess v -> return (v, widget, enctype) FormSuccess v -> return v

View file

@ -39,7 +39,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{BrowseR}> <a href=@{BrowseR}>
[📚 Browse projects] [📚 Browse projects]
<span> <span>
<a href=@{PublishR}> <a href=@{HomeR}>
[📣 Publish an activity] [📣 Publish an activity]
<span> <span>
<a href=@{AuthR LogoutR}> <a href=@{AuthR LogoutR}>

View file

@ -19,8 +19,14 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<ul> <ul>
<li> <li>
<a href=@{RepoNewR}>
Create a new repository
<li> <li>
<a href=@{DeckNewR}> <a href=@{DeckNewR}>
Create a new ticket tracker Create a new ticket tracker
<a href=@{PublishR}> <li>
Publish an activity <a href=@{LoomNewR}>
Create a new patch tracker
<li>
<a href=@{PublishOfferMergeR}>
Open a merge request

View file

@ -127,9 +127,11 @@
/ HomeR GET / HomeR GET
/browse BrowseR GET /browse BrowseR GET
/notifications NotificationsR GET POST /notifications NotificationsR GET POST
/publish PublishR GET POST -- /publish PublishR GET POST
/inbox InboxDebugR GET /inbox InboxDebugR GET
/publish/offer-merge PublishOfferMergeR GET POST
---- Person ------------------------------------------------------------------ ---- Person ------------------------------------------------------------------
/people/#PersonKeyHashid PersonR GET /people/#PersonKeyHashid PersonR GET