diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 1e80c76..885d37d 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -29,15 +29,18 @@ module Vervis.Client , undoFollowTicket , undoFollowRepo , unresolve + , createMR ) where import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Reader +import Data.Bitraversable +import Data.Maybe +import Data.Text (Text) import Database.Persist import Database.Persist.Sql -import Data.Text (Text) import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import Text.Hamlet @@ -48,6 +51,7 @@ import Yesod.Persist.Core import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import Development.PatchMediaType import Network.FedURI import Web.ActivityPub hiding (Follow, Ticket, Project, Repo) import Yesod.ActivityPub @@ -543,3 +547,76 @@ unresolve shrUser uTicket = runExceptT $ do recips = map encodeRouteHome audLocal ++ audRemote return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) + +createMR + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent + -> TextHtml + -> TextPandocMarkdown + -> FedURI + -> Maybe FedURI + -> PatchMediaType + -> Text + -> m (Either Text (Maybe TextHtml, Audience URIMode, AP.Ticket URIMode, Maybe FedURI)) +createMR shrAuthor title desc uContext muBranch typ diff = runExceptT $ do + 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' + + uTarget = + case context' of + Left _ -> uContext + Right (uTracker, _, _, _) -> uTracker + (_, _, _, audLocal, audRemote) = + collectAudience $ audAuthor : audContext + + recips = map encodeRouteHome audLocal ++ audRemote + ObjURI hBranch luBranch = fromMaybe uContext muBranch + luAuthor = encodeRouteLocal $ SharerR shrAuthor + + ticket = AP.Ticket + { AP.ticketLocal = Nothing + , AP.ticketAttributedTo = luAuthor + , AP.ticketPublished = Nothing + , AP.ticketUpdated = Nothing + , AP.ticketContext = Just uContext + , AP.ticketSummary = title + , AP.ticketContent = TextHtml descHtml + , AP.ticketSource = desc + , AP.ticketAssignedTo = Nothing + , AP.ticketResolved = Nothing + , AP.ticketAttachment = Just + ( hBranch + , MergeRequest + { mrOrigin = Nothing + , mrTarget = luBranch + , mrBundle = Right + ( hLocal + , BundleOffer Nothing $ pure AP.Patch + { AP.patchLocal = Nothing + , AP.patchAttributedTo = luAuthor + , AP.patchPublished = Nothing + , AP.patchType = typ + , AP.patchContent = diff + } + ) + } + ) + } + create = Create + { createObject = CreateTicket ticket + , createTarget = Just uTarget + } + return (Nothing, Audience recips [] [] [] [] [], ticket, Just uTarget) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 852c47a..09f3499 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -59,6 +59,7 @@ import Yesod.Persist.Core import qualified Data.HashMap.Strict as M import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import qualified Database.Esqueleto as E @@ -221,6 +222,26 @@ unresolveForm = renderDivs $ areq fedUriField "Ticket" (Just deft) where deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/p/sandbox/t/20YNl" +createMergeRequestForm :: Form (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo) +createMergeRequestForm = 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) + ] + activityWidget :: Widget -> Enctype -> Widget -> Enctype @@ -228,6 +249,7 @@ activityWidget -> Widget -> Enctype -> Widget -> Enctype -> Widget -> Enctype + -> Widget -> Enctype -> Widget activityWidget widget1 enctype1 @@ -235,7 +257,8 @@ activityWidget widget3 enctype3 widget4 enctype4 widget5 enctype5 - widget6 enctype6 = + widget6 enctype6 + widget7 enctype7 = [whamlet|