diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index f1a3862..9d48d22 100644 --- 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) diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index f1ff7c3..05f3daf 100644 --- 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c1ebdd0..a1004d9 100644 --- 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 diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 107b25c..ef7ccf0 100644 --- 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||] + , 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| +

Open a Merge Request on a Git repo +
+ ^{widget} + + |] + +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 diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 543979e..46c592c 100644 --- 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 diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index c2a32ed..9fa3618 100644 --- 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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 09ab0c6..08161cb 100644 --- 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 diff --git a/src/Web/Text.hs b/src/Web/Text.hs index b8947ff..4fb8ee6 100644 --- 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 . + - Written in 2016, 2018, 2019, 2022 by fr33domlover . - - ♡ 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 diff --git a/src/Yesod/Form/Local.hs b/src/Yesod/Form/Local.hs index a9bec37..a5fd34d 100644 --- 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 diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 44efbd1..d6eff39 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -39,7 +39,7 @@ $# . [📚 Browse projects] - + [📣 Publish an activity] diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index b629791..301e614 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -19,8 +19,14 @@ $# .