UI: Project: Children: Form for adding a child

src/Vervis/Field/Person.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2019, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
+    , 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)

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|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
-    , fieldEnctype = UrlEncoded
-    }
 --TODO use custom fields to ensure uniqueness or other constraints?
 
 data NewTicket = NewTicket

src/Vervis/Foundation.hs

@@ -1040,3 +1040,5 @@ instance YesodBreadcrumbs App where
 
         ProjectRemoveChildR _ _ -> ("", Nothing)
         ProjectRemoveParentR _ _ -> ("", Nothing)
+
+        ProjectAddChildR _ -> ("", Nothing)

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

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

templates/project/children.hamlet

@@ -32,6 +32,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       $if haveAdmin
         <td>^{buttonW POST "Remove" (ProjectRemoveChildR projectHash sourceID)}
 
+$if haveAdmin
+  <p>Add a child:
+  <form method=POST action=@{ProjectAddChildR projectHash} enctype=#{enctypeAC}>
+    ^{widgetAC}
+    <input type=submit>
+
 <h2>Invites
 
 <table>

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