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|

Publish a ticket comment
@@ -266,6 +289,11 @@ activityWidget ^{widget6} + +

Submit a patch (via Create) + + ^{widget7} + |] getUser :: Handler (ShrIdent, PersonId) @@ -297,6 +325,8 @@ getPublishR = do runFormPost $ identifyForm "f5" resolveForm ((_result6, widget6), enctype6) <- runFormPost $ identifyForm "f6" unresolveForm + ((_result7, widget7), enctype7) <- + runFormPost $ identifyForm "f7" createMergeRequestForm defaultLayout $ activityWidget widget1 enctype1 @@ -305,6 +335,7 @@ getPublishR = do widget4 enctype4 widget5 enctype5 widget6 enctype6 + widget7 enctype7 postSharerOutboxR :: ShrIdent -> Handler Text postSharerOutboxR shr = do @@ -363,6 +394,7 @@ data Result | ResultFollow (FedURI, FedURI) | ResultResolve FedURI | ResultUnresolve FedURI + | ResultCreateMR (FedURI, Maybe FedURI, TextHtml, TextPandocMarkdown, PatchMediaType, FileInfo) postPublishR :: Handler Html postPublishR = do @@ -381,6 +413,8 @@ postPublishR = do runFormPost $ identifyForm "f5" resolveForm ((result6, widget6), enctype6) <- runFormPost $ identifyForm "f6" unresolveForm + ((result7, widget7), enctype7) <- + runFormPost $ identifyForm "f7" createMergeRequestForm let result = ResultPublishComment <$> result1 <|> ResultCreateTicket <$> result2 @@ -388,6 +422,7 @@ postPublishR = do <|> ResultFollow <$> result4 <|> ResultResolve <$> result5 <|> ResultUnresolve <$> result6 + <|> ResultCreateMR <$> result7 ep@(Entity _ p) <- requireVerifiedAuth s <- runDB $ getJust $ personIdent p @@ -410,6 +445,11 @@ postPublishR = do ResultUnresolve u -> do (summary, audience, specific) <- ExceptT $ unresolve shrAuthor u undoC ep s summary audience specific + ResultCreateMR (uCtx, muBranch, title, desc, typ, file) -> do + diff <- TE.decodeUtf8 <$> fileSourceByteString file + (summary, audience, ticket, muTarget) <- + ExceptT $ createMR shrAuthor title desc uCtx muBranch typ diff + createTicketC ep s summary audience ticket muTarget case eid of Left err -> setMessage $ toHtml err Right _obiid -> setMessage "Activity published" @@ -421,6 +461,7 @@ postPublishR = do widget4 enctype4 widget5 enctype5 widget6 enctype6 + widget7 enctype7 where publishComment eperson sharer ((hTicket, shrTicket, prj, num), muParent, msg) = do encodeRouteFed <- getEncodeRouteHome diff --git a/src/Vervis/WorkItem.hs b/src/Vervis/WorkItem.hs index 4f7934a..31dea09 100644 --- a/src/Vervis/WorkItem.hs +++ b/src/Vervis/WorkItem.hs @@ -19,6 +19,8 @@ module Vervis.WorkItem , askWorkItemFollowers , contextAudience , authorAudience + , parseTicketContext + , getRemoteContextHttp , getWorkItemDetail , WorkItemTarget (..) ) @@ -123,6 +125,33 @@ contextAudience ctx = authorAudience (Left shr) = AudLocal [LocalActorSharer shr] [] authorAudience (Right (ObjURI h lu)) = AudRemote h [lu] [] +parseTicketContext u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- fromMaybeE (decodeRouteLocal lu) "Not a route" + case route of + ProjectR shr prj -> return $ Left (shr, prj) + RepoR shr rp -> return $ Right (shr, rp) + _ -> throwE "Not a ticket context route" + else return $ Right u + +getRemoteContextHttp name u = do + manager <- asksSite appHttpManager + obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u + unless (objId obj == u) $ + throwE "Project 'id' differs from the URI we fetched" + u' <- + case (objContext obj, objInbox obj) of + (Just c, Nothing) -> do + hl <- hostIsLocal $ objUriAuthority c + when hl $ throwE $ name <> ": remote context has a local context" + pure c + (Nothing, Just _) -> pure u + _ -> throwE "Umm context-inbox thing" + return + (u', objUriAuthority u, objFollowers obj, objTeam obj) + getWorkItemDetail :: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail getWorkItemDetail name v = do @@ -141,20 +170,7 @@ getWorkItemDetail name v = do ctx <- parseTicketContext uCtx author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t) return (Right (u, AP.ticketParticipants tl), ctx, author) - childCtx' <- bifor childCtx pure $ \ u -> do - obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u - unless (objId obj == u) $ - throwE "Project 'id' differs from the URI we fetched" - u' <- - case (objContext obj, objInbox obj) of - (Just c, Nothing) -> do - hl <- hostIsLocal $ objUriAuthority c - when hl $ throwE $ name <> ": remote context has a local context" - pure c - (Nothing, Just _) -> pure u - _ -> throwE "Umm context-inbox thing" - return - (u', objUriAuthority u, objFollowers obj, objTeam obj) + childCtx' <- bitraverse pure (getRemoteContextHttp name) childCtx return $ WorkItemDetail childId childCtx' childAuthor where getWorkItem name (WorkItemSharerTicket shr talid False) = do @@ -219,16 +235,6 @@ getWorkItemDetail name v = do fromMaybeE mticket $ name <> ": No such repo-patch" author' <- lift $ getWorkItemAuthorDetail author return (ltid, Left $ Right (sharerIdent s, repoIdent r), author') - parseTicketContext u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- fromMaybeE (decodeRouteLocal lu) "Not a route" - case route of - ProjectR shr prj -> return $ Left (shr, prj) - RepoR shr rp -> return $ Right (shr, rp) - _ -> throwE "Not a ticket context route" - else return $ Right u parseTicketAuthor u@(ObjURI h lu) = do hl <- hostIsLocal h if hl diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index e1f1c2a..a47afe2 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -832,20 +832,6 @@ newtype TextPandocMarkdown = TextPandocMarkdown } deriving (FromJSON, ToJSON) -data PatchType = PatchTypeDarcs deriving Eq - -instance FromJSON PatchType where - parseJSON = withText "PatchType" parse - where - parse "application/x-darcs-patch" = pure PatchTypeDarcs - parse t = fail $ "Unknown patch mediaType: " ++ T.unpack t - -instance ToJSON PatchType where - toJSON = error "toJSON PatchType" - toEncoding = toEncoding . render - where - render PatchTypeDarcs = "application/x-darcs-patch" :: Text - data PatchLocal = PatchLocal { patchId :: LocalURI , patchContext :: LocalURI