From d9d6b9fcedbd2022fe0118fec6f0fa66e2cda28e Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 27 Apr 2024 20:58:26 +0300 Subject: [PATCH] UI: Project: Children: Form for adding a child --- src/Vervis/Field/Person.hs | 38 +++++++++++++++++++++++++++++- src/Vervis/Form/Ticket.hs | 12 +--------- src/Vervis/Foundation.hs | 2 ++ src/Vervis/Handler/Client.hs | 13 +---------- src/Vervis/Handler/Project.hs | 39 +++++++++++++++++++++++++++++++ templates/project/children.hamlet | 6 +++++ th/routes | 2 ++ 7 files changed, 88 insertions(+), 24 deletions(-) diff --git a/src/Vervis/Field/Person.hs b/src/Vervis/Field/Person.hs index 38aa708..f871422 100644 --- a/src/Vervis/Field/Person.hs +++ b/src/Vervis/Field/Person.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,21 +15,33 @@ module Vervis.Field.Person ( passField + , fedUriField + , capField ) where +import Control.Monad.Trans.Except import Data.Char (isDigit) import Data.Text (Text) import Database.Esqueleto +import Yesod.Core import Yesod.Form.Fields import Yesod.Form.Functions import Yesod.Form.Types import qualified Data.Text as T +import Network.FedURI +import Yesod.Hashids + +import Control.Monad.Trans.Except.Local import Data.Char.Local (isAsciiLetter) +import Vervis.Actor +import Vervis.Data.Actor +import Vervis.FedURI import Vervis.Foundation +import Vervis.Model import Vervis.Model.Ident (text2shr) import Vervis.Settings @@ -62,3 +74,27 @@ passConfirmField = Field passField :: Field Handler Text passField = checkPassLength passConfirmField + +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 + , Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) +capField = checkMMap toCap fst fedUriField + where + toCap u = + runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u) diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 9b5acc5..3d682ce 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/src/Vervis/Form/Ticket.hs @@ -49,6 +49,7 @@ import Network.FedURI import Web.Text import Vervis.FedURI +import Vervis.Field.Person import Vervis.Foundation (App, Form, Handler) import Vervis.Model import Vervis.Model.Ticket @@ -56,17 +57,6 @@ 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 86dc9c9..e3deb9e 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -1040,3 +1040,5 @@ instance YesodBreadcrumbs App where ProjectRemoveChildR _ _ -> ("", Nothing) ProjectRemoveParentR _ _ -> ("", Nothing) + + ProjectAddChildR _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index a7f3bac..bd0fa62 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -107,6 +107,7 @@ import Vervis.Client import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.FedURI +import Vervis.Field.Person import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model @@ -1227,18 +1228,6 @@ postProjectTicketOpenR shr prj ltkhid = do redirect $ ProjectTicketR shr prj ltkhid -} -capField - :: Field Handler - ( FedURI - , Either - (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) - FedURI - ) -capField = checkMMap toCap fst fedUriField - where - toCap u = - runExceptT $ (u,) <$> nameExceptT "Capability URI" (parseActivityURI u) - getSender :: Handler (Entity Person, Actor) getSender = do ep@(Entity _ p) <- requireAuth diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index c3902a6..1b7d17c 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -46,6 +46,8 @@ module Vervis.Handler.Project , postProjectRemoveChildR , postProjectRemoveParentR + + , postProjectAddChildR ) where @@ -73,6 +75,7 @@ import Yesod.Auth import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) import Yesod.Form.Functions (runFormPost, runFormGet) +import Yesod.Form import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) @@ -683,6 +686,7 @@ getProjectChildrenR projectHash = do haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do personID <- MaybeT $ pure mp MaybeT $ getCapability personID (Left $ projectResource project) AP.RoleAdmin + ((_, widgetAC), enctypeAC) <- runFormPost addChildForm invites <- handlerToWidget $ runDB $ do sources <- E.select $ E.from $ \ (source `E.InnerJoin` holder `E.LeftOuterJoin` deleg) -> do E.on $ E.just (source E.^. SourceId) E.==. deleg E.?. SourceUsSendDelegatorSource @@ -1040,3 +1044,38 @@ postProjectRemoveParentR projectHash destID = do Right removeID -> setMessage "Remove sent" redirect $ ProjectParentsR projectHash + +addChildForm = renderDivs $ + areq fedUriField "(URI) Child project" Nothing + +postProjectAddChildR :: KeyHashid Project -> Handler Html +postProjectAddChildR projectHash = do + uChild <- runFormPostRedirect (ProjectChildrenR projectHash) addChildForm + encodeRouteHome <- getEncodeRouteHome + let uCollection = encodeRouteHome $ ProjectChildrenR projectHash + + projectID <- decodeKeyHashid404 projectHash + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + + result <- runExceptT $ do + project <- lift $ runDB $ get404 projectID + (maybeSummary, audience, add) <- C.add personID uChild uCollection AP.RoleAdmin + cap <- do + let resourceID = projectResource project + maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to be have Admin access to the Project to add children" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + Right removeID -> + setMessage "Add sent" + redirect $ ProjectChildrenR projectHash diff --git a/templates/project/children.hamlet b/templates/project/children.hamlet index f0407cc..1df07fd 100644 --- a/templates/project/children.hamlet +++ b/templates/project/children.hamlet @@ -32,6 +32,12 @@ $# . $if haveAdmin ^{buttonW POST "Remove" (ProjectRemoveChildR projectHash sourceID)} +$if haveAdmin +

Add a child: +

+ ^{widgetAC} + +

Invites diff --git a/th/routes b/th/routes index f009ad4..3d46a80 100644 --- a/th/routes +++ b/th/routes @@ -356,3 +356,5 @@ /projects/#ProjectKeyHashid/child/remove/#SourceId ProjectRemoveChildR POST /projects/#ProjectKeyHashid/parent/remove/#DestId ProjectRemoveParentR POST + +/projects/#ProjectKeyHashid/child/add ProjectAddChildR POST