Client: Add form for submitting a patch to a repo
This commit is contained in:
fr33domlover
parent
32adee0a75
commit
7812fa6e8f
4 changed files with 150 additions and 40 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue