diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index b9312aa..ff6c134 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -24,7 +24,7 @@ module Vervis.Client --, followProject --, followTicket --, followRepo - --, offerTicket + , offerIssue --, resolve --, undoFollowSharer --, undoFollowProject @@ -299,55 +299,65 @@ followRepo shrAuthor shrObject rpObject hide = do let uObject = encodeRouteHome $ RepoR shrObject rpObject follow shrAuthor uObject uObject hide -} +-} + +offerIssue + :: KeyHashid Person -> Text -> PandocMarkdown -> FedURI + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode) +offerIssue senderHash title desc uTracker = do + + tracker <- do + tracker <- checkTracker uTracker + case tracker of + TrackerDeck deckID -> Left <$> encodeKeyHashid deckID + TrackerLoom _ -> throwE "Local patch tracker doesn't take issues" + 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) -offerTicket - :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) - => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, AP.Ticket URIMode, FedURI)) -offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do - error "Temporarily disabled" - {- - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome descHtml <- ExceptT . pure $ renderPandocMarkdown desc - summary <- - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - #{shr2text shrAuthor} - \ offered a ticket to project # - - ./s/#{shr2text shr}/p/#{prj2text prj} - : #{preEscapedToHtml title}. - |] - let recipsA = [ProjectR shr prj] - recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj] + + encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksSite siteInstanceHost + + let audAuthor = + AudLocal [] [LocalStagePersonFollowers senderHash] + audTracker = + case tracker of + Left deckHash -> + AudLocal + [LocalActorDeck deckHash] + [LocalStageDeckFollowers deckHash] + Right (remoteActor, ObjURI hTracker luTracker) -> + AudRemote hTracker + [luTracker] + (maybeToList $ remoteActorFollowers remoteActor) + + audience = [audAuthor, audTracker] + ticket = AP.Ticket { AP.ticketLocal = Nothing - , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor + , AP.ticketAttributedTo = encodeRouteLocal $ PersonR senderHash , AP.ticketPublished = Nothing , AP.ticketUpdated = Nothing , AP.ticketContext = Nothing - -- , AP.ticketName = Nothing - , AP.ticketSummary = TextHtml title - , AP.ticketContent = TextHtml descHtml - , AP.ticketSource = TextPandocMarkdown desc + , AP.ticketSummary = encodeEntities title + , AP.ticketContent = descHtml + , AP.ticketSource = desc , AP.ticketAssignedTo = Nothing , AP.ticketResolved = Nothing , AP.ticketAttachment = Nothing } - target = encodeRouteHome $ ProjectR shr prj - audience = Audience - { audienceTo = map encodeRouteHome $ recipsA ++ recipsC - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] - , audienceNonActors = map encodeRouteHome recipsC - } - return (summary, audience, ticket, target) + return (Nothing, audience, ticket) + +{- +{- resolve :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) => ShrIdent diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index ca3c581..9b5acc5 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -14,12 +14,16 @@ -} module Vervis.Form.Ticket - ( --NewTicket (..) - --, newTicketForm + ( fedUriField + + , NewTicket (..) + , NewCloth (..) + , newTicketForm + , newClothForm --, editTicketContentForm --, assignTicketForm --, claimRequestForm - ticketFilterForm + , ticketFilterForm --, ticketDepForm ) where @@ -32,13 +36,19 @@ import Data.Maybe import Data.Text (Text) import Data.Time.Calendar (Day (..)) import Data.Time.Clock (getCurrentTime, UTCTime (..)) +import Data.Traversable import Database.Persist -import Text.HTML.SanitizeXSS +import Yesod.Core import Yesod.Form import Yesod.Persist.Core (runDB) import qualified Data.Text as T +import Development.PatchMediaType +import Network.FedURI +import Web.Text + +import Vervis.FedURI import Vervis.Foundation (App, Form, Handler) import Vervis.Model import Vervis.Model.Ticket @@ -46,18 +56,36 @@ import Vervis.Model.Workflow import Vervis.Ticket import Vervis.TicketFilter (TicketFilter (..)) +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 + } --TODO use custom fields to ensure uniqueness or other constraints? -{- data NewTicket = NewTicket { ntTitle :: Text - , ntDesc :: Text - , ntTParams :: [(WorkflowFieldId, Text)] - , ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)] - , ntCParams :: [WorkflowFieldId] - , ntOffer :: Bool + , ntDesc :: PandocMarkdown + --, ntTParams :: [(WorkflowFieldId, Text)] + --, ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)] + --, ntCParams :: [WorkflowFieldId] } +data NewCloth = NewCloth + { ncTitle :: Text + , ncDesc :: PandocMarkdown + , ncTarget :: Maybe Text + , ncOrigin :: Maybe (FedURI, Maybe Text) + , ncPatch :: Maybe (PatchMediaType, FileInfo) + } + +{- fieldSettings :: Text -> Bool -> FieldSettings App fieldSettings name req = fieldSettingsLabel $ @@ -103,9 +131,11 @@ cfield (Entity fid f) = in if workflowFieldRequired f then mkval <$> areq checkBoxField sets Nothing else mkval . fromMaybe False <$> aopt checkBoxField sets Nothing +-} newTicketForm :: WorkflowId -> Form NewTicket newTicketForm wid html = do + {- (tfs, efs, cfs) <- lift $ runDB $ do tfs <- selectList [ WorkflowFieldWorkflow ==. wid @@ -128,16 +158,37 @@ newTicketForm wid html = do ] [] return (tfs, efs, cfs) + -} flip renderDivs html $ NewTicket - <$> (sanitizeBalance <$> areq textField "Title*" Nothing) - <*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$> - aopt textareaField "Description (Markdown)" Nothing + <$> (areq textField "Title*" Nothing) + <*> ( pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$> + areq textareaField "Description (Markdown)*" Nothing ) - <*> (catMaybes <$> traverse tfield tfs) - <*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs) - <*> (catMaybes <$> traverse cfield cfs) - <*> areq checkBoxField "Offer" Nothing --} + -- <*> (catMaybes <$> traverse tfield tfs) + -- <*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs) + -- <*> (catMaybes <$> traverse cfield cfs) + +newClothForm :: Form NewCloth +newClothForm = renderDivs $ mk + <$> (areq textField "Title*" Nothing) + <*> ( pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$> + areq textareaField "Description (Markdown)*" Nothing + ) + <*> aopt textField "Target branch" Nothing + <*> aopt fedUriField "Origin repo" Nothing + <*> aopt textField "Origin branch" Nothing + <*> aopt (selectFieldList typeList) "Patch type" Nothing + <*> aopt fileField "Patch file" Nothing + where + typeList :: [(Text, PatchMediaType)] + typeList = + [ ("Darcs", PatchMediaTypeDarcs) + , ("Git" , PatchMediaTypeGit) + ] + mk title desc targetBranch originRepo originBranch typ file = + NewCloth + title desc targetBranch + ((,originBranch) <$> originRepo) ((,) <$> typ <*> file) {- editTicketContentAForm :: Ticket -> AForm Handler Ticket diff --git a/src/Vervis/Form/Project.hs b/src/Vervis/Form/Tracker.hs similarity index 95% rename from src/Vervis/Form/Project.hs rename to src/Vervis/Form/Tracker.hs index c2337b7..ad6a5e9 100644 --- a/src/Vervis/Form/Project.hs +++ b/src/Vervis/Form/Tracker.hs @@ -13,9 +13,9 @@ - . -} -module Vervis.Form.Project - ( NewProject (..) - , newProjectForm +module Vervis.Form.Tracker + ( NewDeck (..) + , newDeckForm , NewLoom (..) , newLoomForm --, NewProjectCollab (..) @@ -41,13 +41,13 @@ import Yesod.Hashids import Vervis.Foundation import Vervis.Model -data NewProject = NewProject - { npName :: Text - , npDesc :: Text +data NewDeck = NewDeck + { ndName :: Text + , ndDesc :: Text } -newProjectForm :: Form NewProject -newProjectForm = renderDivs $ NewProject +newDeckForm :: Form NewDeck +newDeckForm = renderDivs $ NewDeck <$> areq textField "Name*" Nothing <*> areq textField "Description" Nothing diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 56ad0c1..f0f73f5 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -908,6 +908,7 @@ instance YesodBreadcrumbs App where TicketDepsR d t -> ("Dependencies", Just $ TicketR d t) TicketReverseDepsR d t -> ("Dependants", Just $ TicketR d t) + TicketNewR d -> ("New Ticket", Just $ DeckR d) TicketFollowR _ _ -> ("", Nothing) TicketUnfollowR _ _ -> ("", Nothing) TicketReplyR d t -> ("Reply", Just $ TicketR d t) @@ -940,6 +941,7 @@ instance YesodBreadcrumbs App where BundleR l c b -> ("Bundle " <> keyHashidText b, Just $ ClothR l c) PatchR l c b p -> ("Patch " <> keyHashidText p, Just $ BundleR l c b) + ClothNewR l -> ("New Merge Request", Just $ LoomR l) ClothApplyR _ _ -> ("", Nothing) ClothFollowR _ _ -> ("", Nothing) ClothUnfollowR _ _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 0306a44..a6a49a9 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -79,6 +79,7 @@ import Vervis.API import Vervis.Client import Vervis.Data.Actor import Vervis.FedURI +import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -898,93 +899,6 @@ postRepoUnfollowR shrFollowee rpFollowee = do setUnfollowMessage shrAuthor eid redirect $ RepoR shrFollowee rpFollowee -postProjectTicketsR :: ShrIdent -> PrjIdent -> Handler Html -postProjectTicketsR shr prj = do - wid <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - j <- getValBy404 $ UniqueProject prj sid - return $ projectWorkflow j - ((result, widget), enctype) <- runFormPost $ newTicketForm wid - - (eperson, sharer) <- do - ep@(Entity _ p) <- requireVerifiedAuth - s <- runDB $ getJust $ personIdent p - return (ep, s) - let shrAuthor = sharerIdent sharer - - eid <- runExceptT $ do - NewTicket title desc tparams eparams cparams offer <- - case result of - FormMissing -> throwE "Field(s) missing." - FormFailure _l -> - throwE "Ticket submission failed, see errors below." - FormSuccess nt -> return nt - unless (null tparams && null eparams && null cparams) $ - throwE "Custom param support currently disabled" - {- - let mktparam (fid, v) = TicketParamText - { ticketParamTextTicket = tid - , ticketParamTextField = fid - , ticketParamTextValue = v - } - insertMany_ $ map mktparam $ ntTParams nt - let mkeparam (fid, v) = TicketParamEnum - { ticketParamEnumTicket = tid - , ticketParamEnumField = fid - , ticketParamEnumValue = v - } - insertMany_ $ map mkeparam $ ntEParams nt - -} - if offer - then Right <$> do - (summary, audience, ticket, target) <- - ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj - obiid <- offerTicketC eperson sharer (Just summary) audience ticket target - ExceptT $ runDB $ do - mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid - return $ - case mtal of - Nothing -> - Left - "Offer processed successfully but no ticket \ - \created" - Just tal -> Right $ ticketAuthorLocalTicket tal - else Left <$> do - (summary, audience, Create obj mtarget) <- do - encodeRouteHome <- getEncodeRouteHome - let project = encodeRouteHome $ ProjectR shr prj - ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project - let ticket = - case obj of - CreateTicket _ t -> t - _ -> error "Create object isn't a ticket" - obiid <- createTicketC eperson sharer (Just summary) audience ticket mtarget - ExceptT $ runDB $ do - mtalid <- getKeyBy $ UniqueTicketAuthorLocalOpen obiid - return $ - case mtalid of - Nothing -> - Left - "Create processed successfully but no ticket \ - \created" - Just v -> Right v - case eid of - Left e -> do - setMessage $ toHtml e - defaultLayout $(widgetFile "ticket/new") - Right (Left talid) -> do - talkhid <- encodeKeyHashid talid - redirect $ SharerTicketR shr talkhid - Right (Right ltid) -> do - ltkhid <- encodeKeyHashid ltid - eobiidFollow <- runExceptT $ do - (summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False - followC shrAuthor (Just summary) audience follow - case eobiidFollow of - Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e - Right _ -> setMessage "Ticket created." - redirect $ ProjectTicketR shr prj ltkhid - postProjectTicketCloseR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postProjectTicketCloseR shr prj ltkhid = do @@ -1016,18 +930,6 @@ postProjectTicketOpenR shr prj ltkhid = do 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 - } - capField :: Field Handler ( FedURI diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index b7b9732..0e64c89 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -26,6 +26,9 @@ module Vervis.Handler.Cloth , getClothDepR + , getClothNewR + , postClothNewR + , postClothApplyR , postClothFollowR , postClothUnfollowR @@ -66,6 +69,7 @@ module Vervis.Handler.Cloth ) where +import Control.Exception.Base import Control.Monad import Control.Monad.Trans.Except import Data.Bifunctor @@ -83,10 +87,13 @@ import Network.HTTP.Types.Method import Text.Blaze.Html (Html, preEscapedToHtml) import Yesod.Auth import Yesod.Core +import Yesod.Form import Yesod.Persist.Core import qualified Data.List.NonEmpty as NE import qualified Data.List.Ordered as LO +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Database.Esqueleto as E import Data.MediaType @@ -97,6 +104,7 @@ import Web.Text import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite import Yesod.RenderSource import qualified Web.ActivityPub as AP @@ -104,6 +112,7 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Paginate.Local import Database.Persist.Local +import Yesod.Form.Local import Yesod.Persist.Local import Vervis.ActivityPub @@ -112,6 +121,7 @@ import Vervis.Cloth import Vervis.Data.Actor import Vervis.Persist.Discussion import Vervis.FedURI +import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -129,6 +139,7 @@ import Vervis.Web.Repo import Vervis.Widget import Vervis.Widget.Discussion import Vervis.Widget.Person +import Vervis.Widget.Tracker import qualified Vervis.Client as C @@ -284,10 +295,11 @@ getClothR loomHash clothHash = do where getClothHtml = do mpid <- maybeAuthId - (ticket, targetRepo, author, tparams, eparams, cparams, resolved, moriginRepo, mbundle) <- handlerToWidget $ runDB $ do - (Entity _ loom, Entity _ cloth, Entity ticketID ticket, author, maybeResolve, proposal) <- + (eloom, actor, ticket, targetRepo, author, tparams, eparams, cparams, resolved, moriginRepo, mbundle) <- handlerToWidget $ runDB $ do + (eloom@(Entity _ loom), Entity _ cloth, Entity ticketID ticket, author, maybeResolve, proposal) <- getCloth404 loomHash clothHash - (ticket,,,,,,,,) + actor <- getJust $ loomActor loom + (eloom,actor,ticket,,,,,,,,) <$> getLocalRepo' (loomRepo loom) (ticketLoomBranch cloth) <*> bitraverse (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do @@ -626,6 +638,69 @@ getClothDepR _ _ _ = do tdc -} +getClothNewR :: KeyHashid Loom -> Handler Html +getClothNewR loomHash = do + loomID <- decodeKeyHashid404 loomHash + _ <- runDB $ get404 loomID + ((_result, widget), enctype) <- runFormPost newClothForm + defaultLayout $(widgetFile "cloth/new") + +postClothNewR :: KeyHashid Loom -> Handler Html +postClothNewR loomHash = do + loomID <- decodeKeyHashid404 loomHash + person@(Entity pid p) <- requireAuth + (loom, senderActor) <- runDB $ do + loom <- get404 loomID + a <- getJust $ personActor p + return (loom, a) + NewCloth title desc targetBranch origin patch <- + runFormPostRedirect (ClothNewR loomHash) newClothForm + encodeRouteHome <- getEncodeRouteHome + errorOrTicket <- runExceptT $ do + let uLoom = encodeRouteHome $ LoomR loomHash + senderHash <- encodeKeyHashid pid + (maybeSummary, audience, ticket) <- do + uTargetRepo <- + encodeRouteHome . RepoR <$> encodeKeyHashid (loomRepo loom) + case (origin, patch) of + (Nothing, Nothing) -> throwE "Neither origin no patch provided" + (Just _, Just _) -> throwE "Both origin and patch provided" + (Just (uRepo, mb), Nothing) -> + C.offerMerge + senderHash title desc uLoom uTargetRepo targetBranch + uRepo mb + (Nothing, Just (typ, fi)) -> do + diff <- + withExceptT (T.pack . displayException) $ ExceptT $ + TE.decodeUtf8' <$> fileSourceByteString fi + C.offerPatches + senderHash title desc uLoom uTargetRepo targetBranch + typ (diff :| []) + (localRecips, remoteRecips, fwdHosts, action) <- + lift $ C.makeServerInput Nothing maybeSummary audience $ + AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uLoom + offerID <- + offerTicketC + person senderActor Nothing localRecips remoteRecips fwdHosts action + ticket uLoom + runDBExcept $ do + mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID + tal <- fromMaybeE mtal "Offer processed bu no ticket created" + return $ ticketAuthorLocalTicket tal + case errorOrTicket of + Left e -> do + setMessage $ toHtml e + redirect $ ClothNewR loomHash + Right ticketID -> do + clothID <- do + maybeClothID <- runDB $ getKeyBy $ UniqueTicketLoom ticketID + case maybeClothID of + Nothing -> error "No TicketLoom for the new Ticket" + Just c -> return c + clothHash <- encodeKeyHashid clothID + setMessage "MR created" + redirect $ ClothR loomHash clothHash + postClothApplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler () postClothApplyR loomHash clothHash = do ep@(Entity personID person) <- requireAuth diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 53e3344..7cf7b4f 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -103,8 +103,8 @@ import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Ticket import Vervis.FedURI -import Vervis.Form.Project import Vervis.Form.Ticket +import Vervis.Form.Tracker import Vervis.Foundation import Vervis.Model import Vervis.Paginate @@ -115,6 +115,7 @@ import Vervis.TicketFilter import Vervis.Web.Actor import Vervis.Widget.Person import Vervis.Widget.Ticket +import Vervis.Widget.Tracker import qualified Vervis.Client as C @@ -226,16 +227,20 @@ getDeckFollowersR = getActorFollowersCollection DeckFollowersR deckActor getDeckTicketsR :: KeyHashid Deck -> Handler TypedContent getDeckTicketsR deckHash = selectRep $ do provideRep $ do - ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm + let tf = def + {- + ((filtResult, filtWidget), filtEnctype) <- runFormPost ticketFilterForm let tf = case filtResult of FormSuccess filt -> filt FormMissing -> def FormFailure l -> error $ "Ticket filter form failed: " ++ show l + -} deckID <- decodeKeyHashid404 deckHash - (total, pages, mpage) <- runDB $ do - _ <- get404 deckID + (deck, actor, (total, pages, mpage)) <- runDB $ do + deck <- get404 deckID + actor <- getJust $ deckActor deck let countAllTickets = count [TicketDeckDeck ==. deckID] selectTickets off lim = getTicketSummaries @@ -243,7 +248,7 @@ getDeckTicketsR deckHash = selectRep $ do (Just $ \ t -> [E.desc $ t E.^. TicketId]) (Just (off, lim)) deckID - getPageAndNavCount countAllTickets selectTickets + (deck,actor,) <$> getPageAndNavCount countAllTickets selectTickets case mpage of Nothing -> redirectFirstPage here Just (rows, navModel) -> @@ -319,12 +324,12 @@ getDeckMessageR _ _ = notFound getDeckNewR :: Handler Html getDeckNewR = do - ((_result, widget), enctype) <- runFormPost newProjectForm - defaultLayout $(widgetFile "project/new") + ((_result, widget), enctype) <- runFormPost newDeckForm + defaultLayout $(widgetFile "deck/new") postDeckNewR :: Handler Html postDeckNewR = do - NewProject name desc <- runFormPostRedirect DeckNewR newProjectForm + NewDeck name desc <- runFormPostRedirect DeckNewR newDeckForm personEntity@(Entity personID person) <- requireAuth personHash <- encodeKeyHashid personID diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index ec54906..356dac2 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -80,8 +80,8 @@ import Vervis.Federation.Collab import Vervis.Federation.Discussion import Vervis.Federation.Ticket import Vervis.FedURI -import Vervis.Form.Project import Vervis.Form.Ticket +import Vervis.Form.Tracker import Vervis.Foundation import Vervis.Model import Vervis.Paginate @@ -91,6 +91,7 @@ import Vervis.Ticket import Vervis.TicketFilter import Vervis.Web.Actor import Vervis.Widget.Ticket +import Vervis.Widget.Tracker import qualified Vervis.Client as C @@ -180,16 +181,20 @@ getLoomFollowersR = getActorFollowersCollection LoomFollowersR loomActor getLoomClothsR :: KeyHashid Loom -> Handler TypedContent getLoomClothsR loomHash = selectRep $ do provideRep $ do - ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm + let tf = def + {- + ((filtResult, filtWidget), filtEnctype) <- runFormPost ticketFilterForm let tf = case filtResult of FormSuccess filt -> filt FormMissing -> def FormFailure l -> error $ "Ticket filter form failed: " ++ show l + -} loomID <- decodeKeyHashid404 loomHash - (total, pages, mpage) <- runDB $ do - _ <- get404 loomID + (loom, actor, (total, pages, mpage)) <- runDB $ do + loom <- get404 loomID + actor <- getJust $ loomActor loom let countAllTickets = count [TicketLoomLoom ==. loomID] selectTickets off lim = getClothSummaries @@ -197,7 +202,7 @@ getLoomClothsR loomHash = selectRep $ do (Just $ \ t -> [E.desc $ t E.^. TicketId]) (Just (off, lim)) loomID - getPageAndNavCount countAllTickets selectTickets + (loom,actor,) <$> getPageAndNavCount countAllTickets selectTickets case mpage of Nothing -> redirectFirstPage here Just (rows, navModel) -> diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 147312b..c8d988b 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -24,6 +24,9 @@ module Vervis.Handler.Ticket , getTicketDepR + , getTicketNewR + , postTicketNewR + , postTicketFollowR , postTicketUnfollowR @@ -41,8 +44,6 @@ module Vervis.Handler.Ticket {- , getProjectTicketsR , getProjectTicketTreeR - , getProjectTicketNewR - , putProjectTicketR , deleteProjectTicketR , postProjectTicketR , getProjectTicketEditR @@ -98,7 +99,7 @@ import Network.HTTP.Types (StdMethod (DELETE, POST)) import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html.Renderer.Text import Text.HTML.SanitizeXSS -import Yesod.Auth (requireAuthId, maybeAuthId) +import Yesod.Auth import Yesod.Core hiding (logWarn) import Yesod.Core.Handler import Yesod.Core.Widget @@ -128,17 +129,19 @@ import Yesod.RenderSource import qualified Web.ActivityPub as AP +import Control.Monad.Trans.Except.Local import Data.Either.Local import Data.Maybe.Local (partitionMaybePairs) import Data.Paginate.Local import Database.Persist.Local +import Yesod.Form.Local import Yesod.Persist.Local import Vervis.ActivityPub import Vervis.API import Vervis.Data.Actor -import Vervis.Persist.Discussion import Vervis.FedURI +import Vervis.Form.Ticket import Vervis.Foundation --import Vervis.GraphProxy (ticketDepGraph) import Vervis.Model @@ -147,6 +150,7 @@ import Vervis.Model.Ticket import Vervis.Model.Workflow import Vervis.Paginate import Vervis.Persist.Actor +import Vervis.Persist.Discussion import Vervis.Recipient import Vervis.Settings import Vervis.Style @@ -157,6 +161,9 @@ import Vervis.Web.Actor import Vervis.Web.Discussion import Vervis.Widget.Discussion import Vervis.Widget.Person +import Vervis.Widget.Tracker + +import qualified Vervis.Client as C selectDiscussionID deckHash taskHash = do (_, _, Entity _ ticket, _, _) <- getTicket404 deckHash taskHash @@ -251,10 +258,11 @@ getTicketR deckHash ticketHash = do where getTicketHtml = do mpid <- maybeAuthId - (ticket, author, tparams, eparams, cparams, resolved) <- handlerToWidget $ runDB $ do - (_deck, _ticketdeck, Entity ticketID ticket, author, maybeResolve) <- + (edeck, actor, ticket, author, tparams, eparams, cparams, resolved) <- handlerToWidget $ runDB $ do + (deck, _ticketdeck, Entity ticketID ticket, author, maybeResolve) <- getTicket404 deckHash ticketHash - (ticket,,,,,) + actor <- getJust $ deckActor $ entityVal deck + (deck,actor,ticket,,,,,) <$> bitraverse (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do p <- getJust personID @@ -421,6 +429,54 @@ getTicketDepR _ _ _ = do tdc -} +getTicketNewR :: KeyHashid Deck -> Handler Html +getTicketNewR deckHash = do + deckID <- decodeKeyHashid404 deckHash + wid <- runDB $ deckWorkflow <$> get404 deckID + ((_result, widget), enctype) <- runFormPost $ newTicketForm wid + defaultLayout $(widgetFile "ticket/new") + +postTicketNewR :: KeyHashid Deck -> Handler Html +postTicketNewR deckHash = do + deckID <- decodeKeyHashid404 deckHash + person@(Entity pid p) <- requireAuth + (wid, actor) <- runDB $ do + wid <- deckWorkflow <$> get404 deckID + a <- getJust $ personActor p + return (wid, a) + NewTicket title desc <- + runFormPostRedirect (TicketNewR deckHash) $ newTicketForm wid + errorOrTicket <- runExceptT $ do + encodeRouteHome <- getEncodeRouteHome + let uDeck = encodeRouteHome $ DeckR deckHash + senderHash <- encodeKeyHashid pid + (maybeSummary, audience, ticket) <- + C.offerIssue senderHash title desc uDeck + (localRecips, remoteRecips, fwdHosts, action) <- + lift $ C.makeServerInput Nothing maybeSummary audience $ + AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uDeck + offerID <- + offerTicketC + person actor Nothing localRecips remoteRecips fwdHosts action + ticket uDeck + runDBExcept $ do + mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID + tal <- fromMaybeE mtal "Offer processed bu no ticket created" + return $ ticketAuthorLocalTicket tal + case errorOrTicket of + Left e -> do + setMessage $ toHtml e + redirect $ TicketNewR deckHash + Right ticketID -> do + taskID <- do + maybeTaskID <- runDB $ getKeyBy $ UniqueTicketDeck ticketID + case maybeTaskID of + Nothing -> error "No TicketDeck for the new Ticket" + Just t -> return t + taskHash <- encodeKeyHashid taskID + setMessage "Ticket created" + redirect $ TicketR deckHash taskHash + postTicketFollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler () postTicketFollowR _ = error "Temporarily disabled" @@ -500,75 +556,6 @@ postTicketReplyOnR deckHash taskHash msgHash = do {- -getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html -getProjectTicketNewR shr prj = do - wid <- runDB $ do - Entity sid _ <- getBy404 $ UniqueSharer shr - Entity _ j <- getBy404 $ UniqueProject prj sid - return $ projectWorkflow j - ((_result, widget), enctype) <- runFormPost $ newTicketForm wid - defaultLayout $(widgetFile "ticket/new") - -putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html -putProjectTicketR shr prj ltkhid = do - (tid, ticket, wid) <- runDB $ do - (_es, Entity _ project, Entity tid ticket, _elt, _etcl, _etpl, _author, _) <- getProjectTicket404 shr prj ltkhid - return (tid, ticket, projectWorkflow project) - ((result, widget), enctype) <- - runFormPost $ editTicketContentForm tid ticket wid - case result of - FormSuccess (ticket', tparams, eparams, cparams) -> do - newDescHtml <- - case renderPandocMarkdown $ ticketSource ticket' of - Left err -> do - setMessage $ toHtml err - redirect $ ProjectTicketEditR shr prj ltkhid - Right t -> return t - let ticket'' = ticket' { ticketDescription = newDescHtml } - runDB $ do - replace tid ticket'' - let (tdel, tins, tupd) = partitionMaybePairs tparams - deleteWhere [TicketParamTextId <-. tdel] - let mktparam (fid, v) = TicketParamText - { ticketParamTextTicket = tid - , ticketParamTextField = fid - , ticketParamTextValue = v - } - insertMany_ $ map mktparam tins - traverse_ - (\ (aid, (_fid, v)) -> - update aid [TicketParamTextValue =. v] - ) - tupd - let (edel, eins, eupd) = partitionMaybePairs eparams - deleteWhere [TicketParamEnumId <-. edel] - let mkeparam (fid, v) = TicketParamEnum - { ticketParamEnumTicket = tid - , ticketParamEnumField = fid - , ticketParamEnumValue = v - } - insertMany_ $ map mkeparam eins - traverse_ - (\ (aid, (_fid, v)) -> - update aid [TicketParamEnumValue =. v] - ) - eupd - let (cdel, cins, _ckeep) = partitionMaybePairs cparams - deleteWhere [TicketParamClassId <-. cdel] - let mkcparam fid = TicketParamClass - { ticketParamClassTicket = tid - , ticketParamClassField = fid - } - insertMany_ $ map mkcparam cins - setMessage "Ticket updated." - redirect $ ProjectTicketR shr prj ltkhid - FormMissing -> do - setMessage "Field(s) missing." - defaultLayout $(widgetFile "ticket/edit") - FormFailure _l -> do - setMessage "Ticket update failed, see errors below." - defaultLayout $(widgetFile "ticket/edit") - deleteProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html deleteProjectTicketR _shr _prj _ltkhid = --TODO: I can easily implement this, but should it even be possible to diff --git a/src/Vervis/Widget/Project.hs b/src/Vervis/Widget/Project.hs deleted file mode 100644 index a6cb135..0000000 --- a/src/Vervis/Widget/Project.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2019 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Vervis.Widget.Project - ( projectNavW - ) -where - -import Vervis.Foundation -import Vervis.Model -import Vervis.Model.Ident -import Vervis.Settings -import Vervis.Widget.Workflow - -projectNavW :: Project -> Workflow -> Sharer -> ShrIdent -> PrjIdent -> Widget -projectNavW project workflow wsharer shar proj = - $(widgetFile "project/widget/nav") diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs new file mode 100644 index 0000000..a7b615f --- /dev/null +++ b/src/Vervis/Widget/Tracker.hs @@ -0,0 +1,40 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Widget.Tracker + ( deckNavW + , loomNavW + ) +where + +import Database.Persist.Types + +import Yesod.Hashids + +import Vervis.Foundation +import Vervis.Model +import Vervis.Settings + +deckNavW :: Entity Deck -> Actor -> Widget +deckNavW (Entity deckID deck) actor = do + deckHash <- encodeKeyHashid deckID + hashRepo <- getEncodeKeyHashid + $(widgetFile "deck/widget/nav") + +loomNavW :: Entity Loom -> Actor -> Widget +loomNavW (Entity loomID loom) actor = do + loomHash <- encodeKeyHashid loomID + hashRepo <- getEncodeKeyHashid + $(widgetFile "loom/widget/nav") diff --git a/templates/cloth/list.hamlet b/templates/cloth/list.hamlet index 957835e..72fffcc 100644 --- a/templates/cloth/list.hamlet +++ b/templates/cloth/list.hamlet @@ -12,16 +12,18 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -$#

-$# Create new… +^{loomNavW (Entity loomID loom) actor} + +

+ Create new… $#

$# View as tree… -

- ^{filtWidget} -
- +$# +$# ^{filtWidget} +$#
+$# ^{pageNav} diff --git a/templates/cloth/one.hamlet b/templates/cloth/one.hamlet index 6f3b243..20b4766 100644 --- a/templates/cloth/one.hamlet +++ b/templates/cloth/one.hamlet @@ -13,6 +13,8 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . +^{loomNavW eloom actor} +

#{ticketTitle ticket}
diff --git a/templates/project/claim-request/list.hamlet b/templates/deck/claim-request/list.hamlet similarity index 100% rename from templates/project/claim-request/list.hamlet rename to templates/deck/claim-request/list.hamlet diff --git a/templates/project/collab/list.hamlet b/templates/deck/collab/list.hamlet similarity index 100% rename from templates/project/collab/list.hamlet rename to templates/deck/collab/list.hamlet diff --git a/templates/project/collab/new.hamlet b/templates/deck/collab/new.hamlet similarity index 100% rename from templates/project/collab/new.hamlet rename to templates/deck/collab/new.hamlet diff --git a/templates/project/collab/one.hamlet b/templates/deck/collab/one.hamlet similarity index 100% rename from templates/project/collab/one.hamlet rename to templates/deck/collab/one.hamlet diff --git a/templates/project/edit.hamlet b/templates/deck/edit.hamlet similarity index 100% rename from templates/project/edit.hamlet rename to templates/deck/edit.hamlet diff --git a/templates/project/list.hamlet b/templates/deck/list.hamlet similarity index 100% rename from templates/project/list.hamlet rename to templates/deck/list.hamlet diff --git a/templates/project/new.hamlet b/templates/deck/new.hamlet similarity index 100% rename from templates/project/new.hamlet rename to templates/deck/new.hamlet diff --git a/templates/project/one.hamlet b/templates/deck/one.hamlet similarity index 100% rename from templates/project/one.hamlet rename to templates/deck/one.hamlet diff --git a/templates/project/role/graph.hamlet b/templates/deck/role/graph.hamlet similarity index 100% rename from templates/project/role/graph.hamlet rename to templates/deck/role/graph.hamlet diff --git a/templates/project/role/new.hamlet b/templates/deck/role/new.hamlet similarity index 100% rename from templates/project/role/new.hamlet rename to templates/deck/role/new.hamlet diff --git a/templates/project/role/one.hamlet b/templates/deck/role/one.hamlet similarity index 100% rename from templates/project/role/one.hamlet rename to templates/deck/role/one.hamlet diff --git a/templates/project/role/op/list.hamlet b/templates/deck/role/op/list.hamlet similarity index 100% rename from templates/project/role/op/list.hamlet rename to templates/deck/role/op/list.hamlet diff --git a/templates/project/role/op/new.hamlet b/templates/deck/role/op/new.hamlet similarity index 100% rename from templates/project/role/op/new.hamlet rename to templates/deck/role/op/new.hamlet diff --git a/templates/project/widget/nav.hamlet b/templates/deck/widget/nav.hamlet similarity index 52% rename from templates/project/widget/nav.hamlet rename to templates/deck/widget/nav.hamlet index 1fce81d..29f07aa 100644 --- a/templates/project/widget/nav.hamlet +++ b/templates/deck/widget/nav.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2019 by fr33domlover . +$# Written in 2019, 2022 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -15,36 +15,29 @@ $# .
[[ 🏗 - - #{prj2text proj} + + =#{keyHashidText deckHash} #{actorName actor} ]] :: - + [📥 Inbox] - + [📤 Outbox] - + [🐤 Followers] - - [🤝 Collaborators] + [🤝 Collaborators] - + [🐛 Tickets] - - [✋ Ticket claim requests] - - [🔁 Ticket workflow: - ^{workflowLinkW wsharer workflow}] - - $maybe _wiki <- projectWiki project - + $maybe repoID <- deckWiki deck + [📖 Wiki] $nothing [No wiki] - + [✏ Edit] diff --git a/templates/loom/widget/nav.hamlet b/templates/loom/widget/nav.hamlet new file mode 100644 index 0000000..6681125 --- /dev/null +++ b/templates/loom/widget/nav.hamlet @@ -0,0 +1,39 @@ +$# This file is part of Vervis. +$# +$# Written in 2019, 2022 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +
+ + [[ 🏗 + + +#{keyHashidText loomHash} #{actorName actor} + ]] :: + + + [📥 Inbox] + + + [📤 Outbox] + + + [🐤 Followers] + + [🤝 Collaborators] + + + [🧩 Merge Requests] + + + [🗃 Repository] + + [✏ Edit] diff --git a/templates/ticket/list.hamlet b/templates/ticket/list.hamlet index 5e13e7f..71c2064 100644 --- a/templates/ticket/list.hamlet +++ b/templates/ticket/list.hamlet @@ -12,16 +12,18 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -$#

-$# Create new… +^{deckNavW (Entity deckID deck) actor} + +

+ Create new… $#

$# View as tree… - - ^{filtWidget} -

- +$# +$# ^{filtWidget} +$#
+$# ^{pageNav} diff --git a/templates/ticket/new.hamlet b/templates/ticket/new.hamlet index 210b1ac..8b32914 100644 --- a/templates/ticket/new.hamlet +++ b/templates/ticket/new.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2022 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -14,7 +14,7 @@ $# . Enter the details and click "Submit" to create a new ticket. - + ^{widget}
diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 60d0278..7ffac70 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -13,6 +13,8 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . +^{deckNavW edeck actor} +

#{ticketTitle ticket}
diff --git a/th/routes b/th/routes index a892a3f..f02f883 100644 --- a/th/routes +++ b/th/routes @@ -224,10 +224,9 @@ /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/deps TicketDepsR GET /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/rdeps TicketReverseDepsR GET --- /decks/#DeckKeyHashid/new-ticket TicketNewR GET POST +/decks/#DeckKeyHashid/new-ticket TicketNewR GET POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/edit TicketEditR GET POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/delete TicketDeleteR POST --- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/accept TicketAcceptR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/close TicketCloseR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/open TicketOpenR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/claim TicketClaimR POST @@ -277,10 +276,9 @@ /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/bundles/#BundleKeyHashid BundleR GET /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/bundles/#BundleKeyHashid/patches/#PatchKeyHashid PatchR GET --- /looms/#LoomKeyHashid/new-cloth ClothNewR GET POST +/looms/#LoomKeyHashid/new-cloth ClothNewR GET POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/edit ClothEditR GET POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/delete ClothDeleteR POST --- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/accept ClothAcceptR POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/close ClothCloseR POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/open ClothOpenR POST -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/claim ClothClaimR POST diff --git a/vervis.cabal b/vervis.cabal index c04f880..e4652d4 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -166,10 +166,10 @@ library Vervis.Form.Discussion --Vervis.Form.Group Vervis.Form.Key - Vervis.Form.Project Vervis.Form.Repo --Vervis.Form.Role Vervis.Form.Ticket + Vervis.Form.Tracker -- Vervis.Form.Workflow Vervis.Formatting Vervis.Foundation @@ -239,10 +239,10 @@ library Vervis.Widget Vervis.Widget.Discussion Vervis.Widget.Person - --Vervis.Widget.Project Vervis.Widget.Repo --Vervis.Widget.Role Vervis.Widget.Ticket + Vervis.Widget.Tracker -- Vervis.Widget.Workflow -- Vervis.Wiki Vervis.WorkItem