Client: Add form for submitting a patch to a repo

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)

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|
             <h1>Publish a ticket comment
             <form method=POST action=@{PublishR} enctype=#{enctype1}>
@@ -266,6 +289,11 @@ activityWidget
             <form method=POST action=@{PublishR} enctype=#{enctype6}>
               ^{widget6}
               <input type=submit>
+
+            <h1>Submit a patch (via Create)
+            <form method=POST action=@{PublishR} enctype=#{enctype7}>
+              ^{widget7}
+              <input type=submit>
         |]
 
 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

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
+    childCtx' <- bitraverse pure (getRemoteContextHttp name) childCtx
-        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)
     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

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