Project routes, handlers and creation UI
This commit is contained in:
Pere Lev
parent
3db602e3bd
commit
372fd35f2c
31 changed files with 885 additions and 86 deletions
|
|
@ -4,3 +4,9 @@ Project
|
|||
|
||||
UniqueProjectActor actor
|
||||
UniqueProjectCreate create
|
||||
|
||||
CollabTopicProject
|
||||
collab CollabId
|
||||
project ProjectId
|
||||
|
||||
UniqueCollabTopicProject collab
|
||||
|
|
|
|||
|
|
@ -173,6 +173,9 @@ verifyResourceAddressed localRecips resource = do
|
|||
verify (GrantResourceLoom l) = do
|
||||
routes <- lookup l $ recipLooms localRecips
|
||||
guard $ routeLoom $ familyLoom routes
|
||||
verify (GrantResourceProject r) = do
|
||||
routes <- lookup r $ recipProjects localRecips
|
||||
guard $ routeProject routes
|
||||
|
||||
verifyRemoteAddressed
|
||||
:: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()
|
||||
|
|
@ -2054,6 +2057,7 @@ actorOutboxItem (LocalActorGroup _) = error "No outbox for Group yet"
|
|||
actorOutboxItem (LocalActorRepo r) = RepoOutboxItemR r
|
||||
actorOutboxItem (LocalActorDeck d) = DeckOutboxItemR d
|
||||
actorOutboxItem (LocalActorLoom l) = LoomOutboxItemR l
|
||||
actorOutboxItem (LocalActorProject l) = ProjectOutboxItemR l
|
||||
|
||||
offerDepC
|
||||
:: Entity Person
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ module Vervis.Actor
|
|||
, RepoRoutes (..)
|
||||
, DeckRoutes (..)
|
||||
, LoomRoutes (..)
|
||||
, ProjectRoutes (..)
|
||||
, DeckFamilyRoutes (..)
|
||||
, LoomFamilyRoutes (..)
|
||||
, RecipientRoutes (..)
|
||||
|
|
@ -138,6 +139,7 @@ data LocalActorBy f
|
|||
| LocalActorRepo (f Repo)
|
||||
| LocalActorDeck (f Deck)
|
||||
| LocalActorLoom (f Loom)
|
||||
| LocalActorProject (f Project)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
|
||||
|
|
@ -156,6 +158,7 @@ hashLocalActorPure ctx = f
|
|||
f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r
|
||||
f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d
|
||||
f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l
|
||||
f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j
|
||||
|
||||
getHashLocalActor
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
|
|
@ -180,6 +183,7 @@ unhashLocalActorPure ctx = f
|
|||
f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r
|
||||
f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d
|
||||
f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l
|
||||
f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j
|
||||
|
||||
unhashLocalActor
|
||||
:: (MonadActor m, StageHashids (ActorEnv m))
|
||||
|
|
@ -258,6 +262,12 @@ data LoomRoutes = LoomRoutes
|
|||
}
|
||||
deriving Eq
|
||||
|
||||
data ProjectRoutes = ProjectRoutes
|
||||
{ routeProject :: Bool
|
||||
, routeProjectFollowers :: Bool
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
data DeckFamilyRoutes = DeckFamilyRoutes
|
||||
{ familyDeck :: DeckRoutes
|
||||
, familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)]
|
||||
|
|
@ -271,11 +281,12 @@ data LoomFamilyRoutes = LoomFamilyRoutes
|
|||
deriving Eq
|
||||
|
||||
data RecipientRoutes = RecipientRoutes
|
||||
{ recipPeople :: [(KeyHashid Person, PersonRoutes)]
|
||||
{ recipPeople :: [(KeyHashid Person , PersonRoutes)]
|
||||
, recipGroups :: [(KeyHashid Group , GroupRoutes)]
|
||||
, recipRepos :: [(KeyHashid Repo , RepoRoutes)]
|
||||
, recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)]
|
||||
, recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)]
|
||||
, recipProjects :: [(KeyHashid Project, ProjectRoutes)]
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
|
|
@ -346,7 +357,6 @@ data Env = forall y. (Typeable y, Yesod y) => Env
|
|||
, envHashidsContext :: HashidsContext
|
||||
, envActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool))
|
||||
, envDeliveryTheater :: DeliveryTheater URIMode
|
||||
--, envYesodSite :: y
|
||||
, envYesodRender :: YesodRender y
|
||||
, envHttpManager :: Manager
|
||||
, envFetch :: ActorFetchShare
|
||||
|
|
@ -469,6 +479,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
looms <- unhashKeys $ recipLooms recips
|
||||
for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
|
||||
(loomID,) . (loom,) <$> unhashKeys cloths
|
||||
projects <- unhashKeys $ recipProjects recips
|
||||
|
||||
-- Grab local actor sets whose stages are allowed for delivery
|
||||
let allowStages'
|
||||
|
|
@ -489,6 +500,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
|
||||
loomsAndClothsForStages =
|
||||
filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
|
||||
projectsForStages =
|
||||
filter (allowStages' id routeProject LocalActorProject) projects
|
||||
|
||||
-- Grab local actors being addressed
|
||||
let localActorsForSelf = concat
|
||||
|
|
@ -497,6 +510,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ]
|
||||
, [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
|
||||
, [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
|
||||
, [ LocalActorProject key | (key, routes) <- projects, routeProject routes ]
|
||||
]
|
||||
|
||||
-- Grab local actors whose followers are going to be delivered to
|
||||
|
|
@ -510,6 +524,8 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
[ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
|
||||
loomIDsForFollowers =
|
||||
[ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
|
||||
projectIDsForFollowers =
|
||||
[ key | (key, routes) <- projectsForStages, routeProjectFollowers routes ]
|
||||
|
||||
-- Grab tickets and cloths whose followers are going to be delivered to
|
||||
let ticketSetsForFollowers =
|
||||
|
|
@ -540,6 +556,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, selectActorIDs repoActor repoIDsForFollowers
|
||||
, selectActorIDs deckActor deckIDsForFollowers
|
||||
, selectActorIDs loomActor loomIDsForFollowers
|
||||
, selectActorIDs projectActor projectIDsForFollowers
|
||||
]
|
||||
ticketIDs <-
|
||||
concat <$>
|
||||
|
|
@ -566,6 +583,7 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do
|
|||
, selectFollowers LocalActorRepo RepoActor followerSetIDs
|
||||
, selectFollowers LocalActorDeck DeckActor followerSetIDs
|
||||
, selectFollowers LocalActorLoom LoomActor followerSetIDs
|
||||
, selectFollowers LocalActorProject ProjectActor followerSetIDs
|
||||
]
|
||||
remotes <- getRemoteFollowers followerSetIDs
|
||||
return (locals, remotes)
|
||||
|
|
|
|||
|
|
@ -92,6 +92,9 @@ verifyResourceAddressed localRecips resource = do
|
|||
verify (GrantResourceLoom l) = do
|
||||
routes <- lookup l $ recipLooms localRecips
|
||||
guard $ routeLoom $ familyLoom routes
|
||||
verify (GrantResourceProject r) = do
|
||||
routes <- lookup r $ recipProjects localRecips
|
||||
guard $ routeProject routes
|
||||
|
||||
verifyRecipientAddressed localRecips recipient = do
|
||||
recipientHash <- hashGrantRecip recipient
|
||||
|
|
@ -384,6 +387,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
|
||||
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
|
||||
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
|
||||
Left (GrantResourceProject l) -> Just $ LocalActorProject l
|
||||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
|
||||
|
|
@ -395,6 +399,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
|
||||
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
|
||||
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
|
||||
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
|
||||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
|
||||
|
|
@ -484,6 +489,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r
|
||||
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
|
||||
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
|
||||
Left (GrantResourceProject l) -> Just $ LocalActorProject l
|
||||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
|
||||
|
|
@ -495,6 +501,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r
|
||||
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
|
||||
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
|
||||
Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l
|
||||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
|
||||
|
|
|
|||
62
src/Vervis/Actor/Project.hs
Normal file
62
src/Vervis/Actor/Project.hs
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Actor.Project
|
||||
(
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Database.Persist
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Control.Concurrent.Actor
|
||||
import Network.FedURI
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Discussion
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Persist.Discussion
|
||||
import Vervis.Ticket
|
||||
|
||||
projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next)
|
||||
projectBehavior now projectID (Left _verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
_ -> throwE "Unsupported activity type for Project"
|
||||
projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"
|
||||
|
||||
instance VervisActor Project where
|
||||
actorBehavior = projectBehavior
|
||||
|
|
@ -110,6 +110,7 @@ import Vervis.Actor.Deck
|
|||
import Vervis.Actor.Group
|
||||
import Vervis.Actor.Loom
|
||||
import Vervis.Actor.Person
|
||||
import Vervis.Actor.Project
|
||||
import Vervis.Actor.Repo
|
||||
import Vervis.Darcs
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -130,6 +131,7 @@ import Vervis.Handler.Group
|
|||
import Vervis.Handler.Key
|
||||
import Vervis.Handler.Loom
|
||||
import Vervis.Handler.Person
|
||||
import Vervis.Handler.Project
|
||||
import Vervis.Handler.Repo
|
||||
--import Vervis.Handler.Role
|
||||
--import Vervis.Handler.Sharer
|
||||
|
|
@ -349,6 +351,7 @@ makeFoundation appSettings = do
|
|||
, selectAll LocalActorRepo
|
||||
, selectAll LocalActorDeck
|
||||
, selectAll LocalActorLoom
|
||||
, selectAll LocalActorProject
|
||||
]
|
||||
where
|
||||
selectAll
|
||||
|
|
|
|||
|
|
@ -37,6 +37,7 @@ module Vervis.Client
|
|||
, createDeck
|
||||
, createLoom
|
||||
, createRepo
|
||||
, createProject
|
||||
, invite
|
||||
, remove
|
||||
)
|
||||
|
|
@ -949,6 +950,27 @@ createRepo senderHash name desc = do
|
|||
|
||||
return (Nothing, audience, detail)
|
||||
|
||||
createProject
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> KeyHashid Person
|
||||
-> Text
|
||||
-> Text
|
||||
-> m (Maybe HTML, [Aud URIMode], AP.ActorDetail)
|
||||
createProject senderHash name desc = do
|
||||
let audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audAuthor]
|
||||
|
||||
detail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeProject
|
||||
, AP.actorUsername = Nothing
|
||||
, AP.actorName = Just name
|
||||
, AP.actorSummary = Just desc
|
||||
}
|
||||
|
||||
return (Nothing, audience, detail)
|
||||
|
||||
invite
|
||||
:: PersonId
|
||||
-> FedURI
|
||||
|
|
@ -1012,6 +1034,8 @@ invite personID uRecipient uResource role = do
|
|||
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
|
||||
Left (GrantResourceLoom l) ->
|
||||
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
|
||||
Left (GrantResourceProject l) ->
|
||||
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
|
|
@ -1093,6 +1117,8 @@ remove personID uRecipient uResource = do
|
|||
AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
|
||||
Left (GrantResourceLoom l) ->
|
||||
AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
|
||||
Left (GrantResourceProject l) ->
|
||||
AudLocal [LocalActorProject l] [LocalStageProjectFollowers l]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
|
|
|
|||
|
|
@ -80,6 +80,7 @@ parseLocalActivityURI luAct = do
|
|||
parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i)
|
||||
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
|
||||
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
|
||||
parseOutboxItemRoute (ProjectOutboxItemR r i) = Just (LocalActorProject r, i)
|
||||
parseOutboxItemRoute _ = Nothing
|
||||
|
||||
parseLocalActivityURI'
|
||||
|
|
@ -141,6 +142,7 @@ activityRoute (LocalActorGroup g) = GroupOutboxItemR g
|
|||
activityRoute (LocalActorRepo r) = RepoOutboxItemR r
|
||||
activityRoute (LocalActorDeck d) = DeckOutboxItemR d
|
||||
activityRoute (LocalActorLoom l) = LoomOutboxItemR l
|
||||
activityRoute (LocalActorProject r) = ProjectOutboxItemR r
|
||||
|
||||
stampRoute :: LocalActorBy KeyHashid -> KeyHashid SigKey -> Route App
|
||||
stampRoute (LocalActorPerson p) = PersonStampR p
|
||||
|
|
@ -148,6 +150,7 @@ stampRoute (LocalActorGroup g) = GroupStampR g
|
|||
stampRoute (LocalActorRepo r) = RepoStampR r
|
||||
stampRoute (LocalActorDeck d) = DeckStampR d
|
||||
stampRoute (LocalActorLoom l) = LoomStampR l
|
||||
stampRoute (LocalActorProject r) = ProjectStampR r
|
||||
|
||||
parseStampRoute
|
||||
:: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey)
|
||||
|
|
@ -156,6 +159,7 @@ parseStampRoute (GroupStampR g i) = Just (LocalActorGroup g, i)
|
|||
parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i)
|
||||
parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i)
|
||||
parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i)
|
||||
parseStampRoute (ProjectStampR r i) = Just (LocalActorProject r, i)
|
||||
parseStampRoute _ = Nothing
|
||||
|
||||
localActorID :: LocalActorBy Entity -> ActorId
|
||||
|
|
@ -164,6 +168,7 @@ localActorID (LocalActorGroup (Entity _ g)) = groupActor g
|
|||
localActorID (LocalActorRepo (Entity _ r)) = repoActor r
|
||||
localActorID (LocalActorDeck (Entity _ d)) = deckActor d
|
||||
localActorID (LocalActorLoom (Entity _ l)) = loomActor l
|
||||
localActorID (LocalActorProject (Entity _ r)) = projectActor r
|
||||
|
||||
parseFedURIOld
|
||||
:: ( MonadSite m
|
||||
|
|
|
|||
|
|
@ -85,6 +85,7 @@ import Vervis.Model
|
|||
parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
|
||||
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
|
||||
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
|
||||
parseGrantResource (ProjectR l) = Just $ GrantResourceProject l
|
||||
parseGrantResource _ = Nothing
|
||||
|
||||
data GrantRecipBy f = GrantRecipPerson (f Person)
|
||||
|
|
@ -230,11 +231,6 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
|
|||
resourceHash
|
||||
"Grant resource contains invalid hashid"
|
||||
else pure $ Right lu
|
||||
where
|
||||
parseGrantResource (RepoR r) = Just $ GrantResourceRepo r
|
||||
parseGrantResource (DeckR d) = Just $ GrantResourceDeck d
|
||||
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
|
||||
parseGrantResource _ = Nothing
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
|
|
@ -277,11 +273,13 @@ grantResourceActorID :: GrantResourceBy Identity -> ActorId
|
|||
grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
|
||||
grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d
|
||||
grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l
|
||||
grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l
|
||||
|
||||
data GrantResourceBy f
|
||||
= GrantResourceRepo (f Repo)
|
||||
| GrantResourceDeck (f Deck)
|
||||
| GrantResourceLoom (f Loom)
|
||||
| GrantResourceProject (f Project)
|
||||
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
|
||||
|
|
@ -294,6 +292,8 @@ unhashGrantResourcePure ctx = f
|
|||
GrantResourceDeck <$> decodeKeyHashidPure ctx d
|
||||
f (GrantResourceLoom l) =
|
||||
GrantResourceLoom <$> decodeKeyHashidPure ctx l
|
||||
f (GrantResourceProject l) =
|
||||
GrantResourceProject <$> decodeKeyHashidPure ctx l
|
||||
|
||||
unhashGrantResource resource = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
|
|
@ -317,6 +317,8 @@ hashGrantResource (GrantResourceDeck k) =
|
|||
GrantResourceDeck <$> encodeKeyHashid k
|
||||
hashGrantResource (GrantResourceLoom k) =
|
||||
GrantResourceLoom <$> encodeKeyHashid k
|
||||
hashGrantResource (GrantResourceProject k) =
|
||||
GrantResourceProject <$> encodeKeyHashid k
|
||||
|
||||
hashGrantResource' (GrantResourceRepo k) =
|
||||
GrantResourceRepo <$> WAP.encodeKeyHashid k
|
||||
|
|
@ -324,6 +326,8 @@ hashGrantResource' (GrantResourceDeck k) =
|
|||
GrantResourceDeck <$> WAP.encodeKeyHashid k
|
||||
hashGrantResource' (GrantResourceLoom k) =
|
||||
GrantResourceLoom <$> WAP.encodeKeyHashid k
|
||||
hashGrantResource' (GrantResourceProject k) =
|
||||
GrantResourceProject <$> WAP.encodeKeyHashid k
|
||||
|
||||
getGrantResource (GrantResourceRepo k) e =
|
||||
GrantResourceRepo <$> getEntityE k e
|
||||
|
|
@ -331,6 +335,8 @@ getGrantResource (GrantResourceDeck k) e =
|
|||
GrantResourceDeck <$> getEntityE k e
|
||||
getGrantResource (GrantResourceLoom k) e =
|
||||
GrantResourceLoom <$> getEntityE k e
|
||||
getGrantResource (GrantResourceProject k) e =
|
||||
GrantResourceProject <$> getEntityE k e
|
||||
|
||||
getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
|
||||
where
|
||||
|
|
@ -340,8 +346,11 @@ getGrantResource404 = maybe notFound return <=< getGrantResourceEntity
|
|||
fmap GrantResourceDeck <$> getEntity k
|
||||
getGrantResourceEntity (GrantResourceLoom k) =
|
||||
fmap GrantResourceLoom <$> getEntity k
|
||||
getGrantResourceEntity (GrantResourceProject k) =
|
||||
fmap GrantResourceProject <$> getEntity k
|
||||
|
||||
grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f
|
||||
grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r
|
||||
grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d
|
||||
grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l
|
||||
grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l
|
||||
|
|
|
|||
|
|
@ -222,3 +222,4 @@ messageRoute (LocalActorGroup g) = GroupMessageR g
|
|||
messageRoute (LocalActorRepo r) = RepoMessageR r
|
||||
messageRoute (LocalActorDeck d) = DeckMessageR d
|
||||
messageRoute (LocalActorLoom l) = LoomMessageR l
|
||||
messageRoute (LocalActorProject l) = ProjectMessageR l
|
||||
|
|
|
|||
|
|
@ -16,10 +16,14 @@
|
|||
module Vervis.Form.Tracker
|
||||
( NewDeck (..)
|
||||
, newDeckForm
|
||||
, NewProject (..)
|
||||
, newProjectForm
|
||||
, NewLoom (..)
|
||||
, newLoomForm
|
||||
, DeckInvite (..)
|
||||
, deckInviteForm
|
||||
, ProjectInvite (..)
|
||||
, projectInviteForm
|
||||
--, NewProjectCollab (..)
|
||||
--, newProjectCollabForm
|
||||
--, editProjectForm
|
||||
|
|
@ -56,6 +60,16 @@ newDeckForm = renderDivs $ NewDeck
|
|||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
|
||||
data NewProject = NewProject
|
||||
{ npName :: Text
|
||||
, npDesc :: Text
|
||||
}
|
||||
|
||||
newProjectForm :: Form NewProject
|
||||
newProjectForm = renderDivs $ NewProject
|
||||
<$> areq textField "Name*" Nothing
|
||||
<*> areq textField "Description" Nothing
|
||||
|
||||
data NewLoom = NewLoom
|
||||
{ nlName :: Text
|
||||
, nlDesc :: Text
|
||||
|
|
@ -115,6 +129,38 @@ deckInviteForm deckID = renderDivs $ DeckInvite
|
|||
l
|
||||
selectRole = selectField optionsEnum
|
||||
|
||||
data ProjectInvite = ProjectInvite
|
||||
{ jiPerson :: PersonId
|
||||
, jiRole :: AP.Role
|
||||
}
|
||||
|
||||
projectInviteForm :: ProjectId -> Form ProjectInvite
|
||||
projectInviteForm projectID = renderDivs $ ProjectInvite
|
||||
<$> areq selectPerson "Person*" Nothing
|
||||
<*> areq selectRole "Role*" Nothing
|
||||
where
|
||||
selectPerson = selectField $ do
|
||||
l <- runDB $ E.select $
|
||||
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab E.&&.
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID
|
||||
E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
|
||||
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
|
||||
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
|
||||
return (person, actor)
|
||||
optionsPairs $
|
||||
map (\ (Entity pid p, Entity _ a) ->
|
||||
( T.concat
|
||||
[ actorName a
|
||||
, " ~"
|
||||
, username2text $ personUsername p
|
||||
]
|
||||
, pid
|
||||
)
|
||||
)
|
||||
l
|
||||
selectRole = selectField optionsEnum
|
||||
|
||||
{-
|
||||
editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
|
||||
editProjectAForm sid (Entity jid project) = Project
|
||||
|
|
|
|||
|
|
@ -157,6 +157,7 @@ type LoomKeyHashid = KeyHashid Loom
|
|||
type TicketDeckKeyHashid = KeyHashid TicketDeck
|
||||
type TicketLoomKeyHashid = KeyHashid TicketLoom
|
||||
type SigKeyKeyHashid = KeyHashid SigKey
|
||||
type ProjectKeyHashid = KeyHashid Project
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
|
|
@ -982,3 +983,20 @@ instance YesodBreadcrumbs App where
|
|||
ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c)
|
||||
|
||||
ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c)
|
||||
|
||||
ProjectR d -> ("Project $" <> keyHashidText d, Just HomeR)
|
||||
ProjectInboxR d -> ("Inbox", Just $ ProjectR d)
|
||||
ProjectOutboxR d -> ("Outbox", Just $ ProjectR d)
|
||||
ProjectOutboxItemR d i -> (keyHashidText i, Just $ ProjectOutboxR d)
|
||||
ProjectFollowersR d -> ("Followers", Just $ ProjectR d)
|
||||
|
||||
ProjectMessageR d m -> ("Message #" <> keyHashidText m, Just $ ProjectR d)
|
||||
|
||||
ProjectNewR -> ("New Project", Just HomeR)
|
||||
|
||||
ProjectStampR d k -> ("Stamp #" <> keyHashidText k, Just $ ProjectR d)
|
||||
|
||||
ProjectCollabsR d -> ("Collaborators", Just $ ProjectR d)
|
||||
|
||||
ProjectInviteR d -> ("Invite", Just $ ProjectR d)
|
||||
ProjectRemoveR _ _ -> ("", Nothing)
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ getHomeR = do
|
|||
where
|
||||
personalOverview :: Entity Person -> Handler Html
|
||||
personalOverview (Entity pid _person) = do
|
||||
(repos, decks, looms) <- runDB $ (,,)
|
||||
(repos, decks, looms, projects) <- runDB $ (,,,)
|
||||
<$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
|
||||
E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
|
||||
|
|
@ -153,15 +153,26 @@ getHomeR = do
|
|||
E.orderBy [E.asc $ loom E.^. LoomId]
|
||||
return (loom, actor, collab)
|
||||
)
|
||||
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do
|
||||
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ project E.^. ProjectId]
|
||||
return (project, actor, collab)
|
||||
)
|
||||
hashRepo <- getEncodeKeyHashid
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
hashProject <- getEncodeKeyHashid
|
||||
defaultLayout $(widgetFile "personal-overview")
|
||||
|
||||
getBrowseR :: Handler Html
|
||||
getBrowseR = do
|
||||
(people, groups, repos, decks, looms) <- runDB $
|
||||
(,,,,)
|
||||
(people, groups, repos, decks, looms, projects) <- runDB $
|
||||
(,,,,,)
|
||||
<$> (E.select $ E.from $ \ (person `E.InnerJoin` actor) -> do
|
||||
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
|
||||
E.orderBy [E.asc $ person E.^. PersonId]
|
||||
|
|
@ -187,6 +198,11 @@ getBrowseR = do
|
|||
E.orderBy [E.asc $ loom E.^. LoomId]
|
||||
return (loom, actor)
|
||||
)
|
||||
<*> (E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do
|
||||
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
|
||||
E.orderBy [E.asc $ project E.^. ProjectId]
|
||||
return (project, actor)
|
||||
)
|
||||
{-
|
||||
now <- liftIO getCurrentTime
|
||||
repoRows <- forM repos $
|
||||
|
|
@ -209,6 +225,7 @@ getBrowseR = do
|
|||
hashRepo <- getEncodeKeyHashid
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
hashProject <- getEncodeKeyHashid
|
||||
defaultLayout $ do
|
||||
setTitle "Welcome to Vervis!"
|
||||
$(widgetFile "browse")
|
||||
|
|
|
|||
332
src/Vervis/Handler/Project.hs
Normal file
332
src/Vervis/Handler/Project.hs
Normal file
|
|
@ -0,0 +1,332 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module Vervis.Handler.Project
|
||||
( getProjectR
|
||||
, getProjectInboxR
|
||||
, postProjectInboxR
|
||||
, getProjectOutboxR
|
||||
, getProjectOutboxItemR
|
||||
, getProjectFollowersR
|
||||
|
||||
, getProjectMessageR
|
||||
|
||||
, getProjectNewR
|
||||
, postProjectNewR
|
||||
|
||||
, getProjectStampR
|
||||
|
||||
, getProjectCollabsR
|
||||
, getProjectInviteR
|
||||
, postProjectInviteR
|
||||
, postProjectRemoveR
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Aeson
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Default.Class
|
||||
import Data.Foldable
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Network.HTTP.Types.Method
|
||||
import Text.Blaze.Html (Html)
|
||||
import Yesod.Auth (requireAuth)
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
|
||||
import Yesod.Form.Functions (runFormPost, runFormGet)
|
||||
import Yesod.Form.Types (FormResult (..))
|
||||
import Yesod.Persist.Core (runDB, get404, getBy404)
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Database.Persist.JSON
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Data.Paginate.Local
|
||||
import Database.Persist.Local
|
||||
import Yesod.Form.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.API
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.Federation.Ticket
|
||||
import Vervis.FedURI
|
||||
import Vervis.Form.Ticket
|
||||
import Vervis.Form.Tracker
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Paginate
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
import Vervis.TicketFilter
|
||||
import Vervis.Time
|
||||
import Vervis.Web.Actor
|
||||
import Vervis.Widget
|
||||
import Vervis.Widget.Person
|
||||
import Vervis.Widget.Ticket
|
||||
import Vervis.Widget.Tracker
|
||||
|
||||
import qualified Vervis.Client as C
|
||||
|
||||
getProjectR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
(project, actor, sigKeyIDs) <- runDB $ do
|
||||
d <- get404 projectID
|
||||
let aid = projectActor d
|
||||
a <- getJust aid
|
||||
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
|
||||
return (d, a, sigKeys)
|
||||
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hashSigKey <- getEncodeKeyHashid
|
||||
perActor <- asksSite $ appPerActorKeys . appSettings
|
||||
let projectAP = AP.Project
|
||||
{ AP.projectActor = AP.Actor
|
||||
{ AP.actorLocal = AP.ActorLocal
|
||||
{ AP.actorId = encodeRouteLocal $ ProjectR projectHash
|
||||
, AP.actorInbox = encodeRouteLocal $ ProjectInboxR projectHash
|
||||
, AP.actorOutbox =
|
||||
Just $ encodeRouteLocal $ ProjectOutboxR projectHash
|
||||
, AP.actorFollowers =
|
||||
Just $ encodeRouteLocal $ ProjectFollowersR projectHash
|
||||
, AP.actorFollowing = Nothing
|
||||
, AP.actorPublicKeys =
|
||||
map (Left . encodeRouteLocal) $
|
||||
if perActor
|
||||
then map (ProjectStampR projectHash . hashSigKey) sigKeyIDs
|
||||
else [ActorKey1R, ActorKey2R]
|
||||
, AP.actorSshKeys = []
|
||||
}
|
||||
, AP.actorDetail = AP.ActorDetail
|
||||
{ AP.actorType = AP.ActorTypeProject
|
||||
, AP.actorUsername = Nothing
|
||||
, AP.actorName = Just $ actorName actor
|
||||
, AP.actorSummary = Just $ actorDesc actor
|
||||
}
|
||||
}
|
||||
, AP.projectTracker = Nothing
|
||||
, AP.projectChildren = []
|
||||
, AP.projectParents = []
|
||||
, AP.projectComponents = []
|
||||
}
|
||||
provideHtmlAndAP projectAP $ redirectToPrettyJSON here
|
||||
where
|
||||
here = ProjectR projectHash
|
||||
|
||||
getProjectInboxR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectInboxR = getInbox ProjectInboxR projectActor
|
||||
|
||||
postProjectInboxR :: KeyHashid Project -> Handler ()
|
||||
postProjectInboxR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
postInbox $ LocalActorProject projectID
|
||||
|
||||
getProjectOutboxR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectOutboxR = getOutbox ProjectOutboxR ProjectOutboxItemR projectActor
|
||||
|
||||
getProjectOutboxItemR
|
||||
:: KeyHashid Project -> KeyHashid OutboxItem -> Handler TypedContent
|
||||
getProjectOutboxItemR = getOutboxItem ProjectOutboxItemR projectActor
|
||||
|
||||
getProjectFollowersR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectFollowersR = getActorFollowersCollection ProjectFollowersR projectActor
|
||||
|
||||
getProjectMessageR :: KeyHashid Project -> KeyHashid LocalMessage -> Handler Html
|
||||
getProjectMessageR _ _ = notFound
|
||||
|
||||
getProjectNewR :: Handler Html
|
||||
getProjectNewR = do
|
||||
((_result, widget), enctype) <- runFormPost newProjectForm
|
||||
defaultLayout $(widgetFile "project/new")
|
||||
|
||||
postProjectNewR :: Handler Html
|
||||
postProjectNewR = do
|
||||
NewProject name desc <- runFormPostRedirect ProjectNewR newProjectForm
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
(maybeSummary, audience, detail) <- C.createProject personHash name desc
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateProject detail Nothing) Nothing
|
||||
result <-
|
||||
runExceptT $
|
||||
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect ProjectNewR
|
||||
Right createID -> do
|
||||
maybeProjectID <- runDB $ getKeyBy $ UniqueProjectCreate createID
|
||||
case maybeProjectID of
|
||||
Nothing -> error "Can't find the newly created project"
|
||||
Just projectID -> do
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
setMessage "New project created"
|
||||
redirect $ ProjectR projectHash
|
||||
|
||||
getProjectStampR :: KeyHashid Project -> KeyHashid SigKey -> Handler TypedContent
|
||||
getProjectStampR = servePerActorKey projectActor LocalActorProject
|
||||
|
||||
getProjectCollabsR :: KeyHashid Project -> Handler Html
|
||||
getProjectCollabsR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
(project, actor, collabs, invites, joins) <- runDB $ do
|
||||
project <- get404 projectID
|
||||
actor <- getJust $ projectActor project
|
||||
collabs <- do
|
||||
grants <-
|
||||
getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
for grants $ \ (role, actor, ct, time) ->
|
||||
(,role,ct,time) <$> getPersonWidgetInfo actor
|
||||
invites <- do
|
||||
invites' <-
|
||||
getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
for invites' $ \ (inviter, recip, time, role) -> (,,,)
|
||||
<$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
|
||||
<*> getPersonWidgetInfo recip
|
||||
<*> pure time
|
||||
<*> pure role
|
||||
joins <- do
|
||||
joins' <-
|
||||
getTopicJoins CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
for joins' $ \ (recip, time, role) ->
|
||||
(,time,role) <$> getPersonWidgetInfo recip
|
||||
return (project, actor, collabs, invites, joins)
|
||||
defaultLayout $(widgetFile "project/collab/list")
|
||||
where
|
||||
grabPerson actorID = do
|
||||
actorByKey <- getLocalActor actorID
|
||||
case actorByKey of
|
||||
LocalActorPerson personID -> return personID
|
||||
_ -> error "Surprise, local inviter actor isn't a Person"
|
||||
|
||||
getProjectInviteR :: KeyHashid Project -> Handler Html
|
||||
getProjectInviteR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
((_result, widget), enctype) <- runFormPost $ projectInviteForm projectID
|
||||
defaultLayout $(widgetFile "project/collab/new")
|
||||
|
||||
postProjectInviteR :: KeyHashid Project -> Handler Html
|
||||
postProjectInviteR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
ProjectInvite recipPersonID role <-
|
||||
runFormPostRedirect (ProjectInviteR projectHash) $ projectInviteForm projectID
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
recipPersonHash <- encodeKeyHashid recipPersonID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, invite) <- do
|
||||
let uRecipient = encodeRouteHome $ PersonR recipPersonHash
|
||||
uResource = encodeRouteHome $ ProjectR projectHash
|
||||
C.invite personID uRecipient uResource role
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
|
||||
let cap =
|
||||
Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
|
||||
handleViaActor
|
||||
personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect $ ProjectInviteR projectHash
|
||||
Right inviteID -> do
|
||||
setMessage "Invite sent"
|
||||
redirect $ ProjectCollabsR projectHash
|
||||
|
||||
postProjectRemoveR :: KeyHashid Project -> CollabTopicProjectId -> Handler Html
|
||||
postProjectRemoveR projectHash ctID = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
CollabTopicProject collabID projectID' <- MaybeT $ get ctID
|
||||
guard $ projectID' == projectID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
|
||||
member <-
|
||||
Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
|
||||
Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
|
||||
lift $
|
||||
bitraverse
|
||||
(pure . collabRecipLocalPerson)
|
||||
(getRemoteActorURI <=< getJust . collabRecipRemoteActor)
|
||||
member
|
||||
pidOrU <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uRecipient <-
|
||||
case pidOrU of
|
||||
Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
|
||||
Right u -> pure u
|
||||
let uResource = encodeRouteHome $ ProjectR projectHash
|
||||
C.remove personID uRecipient uResource
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Project to remove people"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
|
||||
let cap =
|
||||
Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
|
||||
handleViaActor
|
||||
personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Remove sent"
|
||||
redirect $ ProjectCollabsR projectHash
|
||||
|
|
@ -100,6 +100,10 @@ instance Hashable LoomId where
|
|||
hashWithSalt salt = hashWithSalt salt . fromSqlKey
|
||||
hash = hash . fromSqlKey
|
||||
|
||||
instance Hashable ProjectId where
|
||||
hashWithSalt salt = hashWithSalt salt . fromSqlKey
|
||||
hash = hash . fromSqlKey
|
||||
|
||||
{-
|
||||
instance PersistEntityGraph Ticket TicketDependency where
|
||||
sourceParam = ticketDependencyParent
|
||||
|
|
|
|||
|
|
@ -81,14 +81,16 @@ getLocalActorEnt actorID = do
|
|||
mr <- getBy $ UniqueRepoActor actorID
|
||||
md <- getBy $ UniqueDeckActor actorID
|
||||
ml <- getBy $ UniqueLoomActor actorID
|
||||
mj <- getBy $ UniqueProjectActor actorID
|
||||
return $
|
||||
case (mp, mg, mr, md, ml) of
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
|
||||
(Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
|
||||
(Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g
|
||||
(Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r
|
||||
(Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d
|
||||
(Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l
|
||||
case (mp, mg, mr, md, ml, mj) of
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"
|
||||
(Just p, Nothing, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p
|
||||
(Nothing, Just g, Nothing, Nothing, Nothing, Nothing) -> LocalActorGroup g
|
||||
(Nothing, Nothing, Just r, Nothing, Nothing, Nothing) -> LocalActorRepo r
|
||||
(Nothing, Nothing, Nothing, Just d, Nothing, Nothing) -> LocalActorDeck d
|
||||
(Nothing, Nothing, Nothing, Nothing, Just l, Nothing) -> LocalActorLoom l
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing, Just j) -> LocalActorProject j
|
||||
_ -> error "Multi-usage of an ActorId"
|
||||
|
||||
getLocalActorEntity
|
||||
|
|
@ -105,6 +107,8 @@ getLocalActorEntity (LocalActorDeck d) =
|
|||
fmap (LocalActorDeck . Entity d) <$> get d
|
||||
getLocalActorEntity (LocalActorLoom l) =
|
||||
fmap (LocalActorLoom . Entity l) <$> get l
|
||||
getLocalActorEntity (LocalActorProject r) =
|
||||
fmap (LocalActorProject . Entity r) <$> get r
|
||||
|
||||
verifyLocalActivityExistsInDB
|
||||
:: MonadIO m
|
||||
|
|
|
|||
|
|
@ -63,15 +63,18 @@ getCollabTopic collabID = do
|
|||
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
|
||||
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
|
||||
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
|
||||
maybeProject <- getValBy $ UniqueCollabTopicProject collabID
|
||||
return $
|
||||
case (maybeRepo, maybeDeck, maybeLoom) of
|
||||
(Nothing, Nothing, Nothing) -> error "Found Collab without topic"
|
||||
(Just r, Nothing, Nothing) ->
|
||||
case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
|
||||
(Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
|
||||
(Just r, Nothing, Nothing, Nothing) ->
|
||||
GrantResourceRepo $ collabTopicRepoRepo r
|
||||
(Nothing, Just d, Nothing) ->
|
||||
(Nothing, Just d, Nothing, Nothing) ->
|
||||
GrantResourceDeck $ collabTopicDeckDeck d
|
||||
(Nothing, Nothing, Just l) ->
|
||||
(Nothing, Nothing, Just l, Nothing) ->
|
||||
GrantResourceLoom $ collabTopicLoomLoom l
|
||||
(Nothing, Nothing, Nothing, Just l) ->
|
||||
GrantResourceProject $ collabTopicProjectProject l
|
||||
_ -> error "Found Collab with multiple topics"
|
||||
|
||||
getCollabTopic'
|
||||
|
|
@ -80,15 +83,18 @@ getCollabTopic' collabID = do
|
|||
maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
|
||||
maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
|
||||
maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
|
||||
maybeProject <- getBy $ UniqueCollabTopicProject collabID
|
||||
return $
|
||||
case (maybeRepo, maybeDeck, maybeLoom) of
|
||||
(Nothing, Nothing, Nothing) -> error "Found Collab without topic"
|
||||
(Just (Entity k r), Nothing, Nothing) ->
|
||||
case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of
|
||||
(Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
|
||||
(Just (Entity k r), Nothing, Nothing, Nothing) ->
|
||||
(delete k, GrantResourceRepo $ collabTopicRepoRepo r)
|
||||
(Nothing, Just (Entity k d), Nothing) ->
|
||||
(Nothing, Just (Entity k d), Nothing, Nothing) ->
|
||||
(delete k, GrantResourceDeck $ collabTopicDeckDeck d)
|
||||
(Nothing, Nothing, Just (Entity k l)) ->
|
||||
(Nothing, Nothing, Just (Entity k l), Nothing) ->
|
||||
(delete k, GrantResourceLoom $ collabTopicLoomLoom l)
|
||||
(Nothing, Nothing, Nothing, Just (Entity k l)) ->
|
||||
(delete k, GrantResourceProject $ collabTopicProjectProject l)
|
||||
_ -> error "Found Collab with multiple topics"
|
||||
|
||||
getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
|
||||
|
|
@ -284,19 +290,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
|
|||
throwE "Collab recipient is someone else"
|
||||
|
||||
-- Find the local topic, on which this Collab gives access
|
||||
topic <- lift $ do
|
||||
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
|
||||
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
|
||||
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
|
||||
case (maybeRepo, maybeDeck, maybeLoom) of
|
||||
(Nothing, Nothing, Nothing) -> error "Collab without topic"
|
||||
(Just r, Nothing, Nothing) ->
|
||||
return $ GrantResourceRepo $ collabTopicRepoRepo r
|
||||
(Nothing, Just d, Nothing) ->
|
||||
return $ GrantResourceDeck $ collabTopicDeckDeck d
|
||||
(Nothing, Nothing, Just l) ->
|
||||
return $ GrantResourceLoom $ collabTopicLoomLoom l
|
||||
_ -> error "Collab with multiple topics"
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
|
||||
-- Verify that topic is indeed the sender of the Grant
|
||||
unless (grantResourceLocalActor topic == capActor) $
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2020, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -92,6 +93,9 @@ getLocalAuthor lmid aid name = do
|
|||
LocalActorLoom loomID -> do
|
||||
loomHash <- encodeKeyHashid loomID
|
||||
return $ "+" <> keyHashidText loomHash
|
||||
LocalActorProject projectID -> do
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
return $ "$" <> keyHashidText projectHash
|
||||
return $ MessageTreeNodeLocal lmid authorByKey code name
|
||||
|
||||
getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@ module Vervis.Recipient
|
|||
, RepoRoutes (..)
|
||||
, DeckRoutes (..)
|
||||
, LoomRoutes (..)
|
||||
, ProjectRoutes (..)
|
||||
, DeckFamilyRoutes (..)
|
||||
, LoomFamilyRoutes (..)
|
||||
, RecipientRoutes (..)
|
||||
|
|
@ -192,6 +193,7 @@ parseLocalActor (GroupR gkhid) = Just $ LocalActorGroup gkhid
|
|||
parseLocalActor (RepoR rkhid) = Just $ LocalActorRepo rkhid
|
||||
parseLocalActor (DeckR dkhid) = Just $ LocalActorDeck dkhid
|
||||
parseLocalActor (LoomR lkhid) = Just $ LocalActorLoom lkhid
|
||||
parseLocalActor (ProjectR jkhid) = Just $ LocalActorProject jkhid
|
||||
parseLocalActor _ = Nothing
|
||||
|
||||
renderLocalActor :: LocalActor -> Route App
|
||||
|
|
@ -200,6 +202,7 @@ renderLocalActor (LocalActorGroup gkhid) = GroupR gkhid
|
|||
renderLocalActor (LocalActorRepo rkhid) = RepoR rkhid
|
||||
renderLocalActor (LocalActorDeck dkhid) = DeckR dkhid
|
||||
renderLocalActor (LocalActorLoom lkhid) = LoomR lkhid
|
||||
renderLocalActor (LocalActorProject jkhid) = ProjectR jkhid
|
||||
|
||||
data LocalStageBy f
|
||||
= LocalStagePersonFollowers (f Person)
|
||||
|
|
@ -213,6 +216,8 @@ data LocalStageBy f
|
|||
|
||||
| LocalStageLoomFollowers (f Loom)
|
||||
| LocalStageClothFollowers (f Loom) (f TicketLoom)
|
||||
|
||||
| LocalStageProjectFollowers (f Project)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalStageBy => Eq (LocalStageBy f)
|
||||
|
|
@ -235,6 +240,8 @@ parseLocalStage (LoomFollowersR lkhid) =
|
|||
Just $ LocalStageLoomFollowers lkhid
|
||||
parseLocalStage (ClothFollowersR lkhid ltkhid) =
|
||||
Just $ LocalStageClothFollowers lkhid ltkhid
|
||||
parseLocalStage (ProjectFollowersR jkhid) =
|
||||
Just $ LocalStageProjectFollowers jkhid
|
||||
parseLocalStage _ = Nothing
|
||||
|
||||
renderLocalStage :: LocalStage -> Route App
|
||||
|
|
@ -252,6 +259,8 @@ renderLocalStage (LocalStageLoomFollowers lkhid) =
|
|||
LoomFollowersR lkhid
|
||||
renderLocalStage (LocalStageClothFollowers lkhid ltkhid) =
|
||||
ClothFollowersR lkhid ltkhid
|
||||
renderLocalStage (LocalStageProjectFollowers jkhid) =
|
||||
ProjectFollowersR jkhid
|
||||
|
||||
parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
|
||||
parseLocalRecipient r =
|
||||
|
|
@ -263,6 +272,7 @@ localActorFollowers (LocalActorGroup g) = LocalStageGroupFollowers g
|
|||
localActorFollowers (LocalActorRepo r) = LocalStageRepoFollowers r
|
||||
localActorFollowers (LocalActorDeck d) = LocalStageDeckFollowers d
|
||||
localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l
|
||||
localActorFollowers (LocalActorProject j) = LocalStageProjectFollowers j
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Converting between KeyHashid, Key, Identity and Entity
|
||||
|
|
@ -327,6 +337,8 @@ hashLocalStagePure ctx = f
|
|||
LocalStageClothFollowers
|
||||
(encodeKeyHashidPure ctx l)
|
||||
(encodeKeyHashidPure ctx c)
|
||||
f (LocalStageProjectFollowers j) =
|
||||
LocalStageProjectFollowers $ encodeKeyHashidPure ctx j
|
||||
|
||||
getHashLocalStage
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -364,6 +376,8 @@ unhashLocalStagePure ctx = f
|
|||
LocalStageClothFollowers
|
||||
<$> decodeKeyHashidPure ctx l
|
||||
<*> decodeKeyHashidPure ctx c
|
||||
f (LocalStageProjectFollowers j) =
|
||||
LocalStageProjectFollowers <$> decodeKeyHashidPure ctx j
|
||||
|
||||
unhashLocalStage
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -405,6 +419,7 @@ getLocalActorID (LocalActorGroup g) = fmap groupActor <$> get g
|
|||
getLocalActorID (LocalActorRepo r) = fmap repoActor <$> get r
|
||||
getLocalActorID (LocalActorDeck d) = fmap deckActor <$> get d
|
||||
getLocalActorID (LocalActorLoom l) = fmap loomActor <$> get l
|
||||
getLocalActorID (LocalActorProject j) = fmap projectActor <$> get j
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Intermediate recipient types
|
||||
|
|
@ -428,6 +443,8 @@ data LeafDeck = LeafDeck | LeafDeckFollowers deriving (Eq, Ord)
|
|||
|
||||
data LeafLoom = LeafLoom | LeafLoomFollowers deriving (Eq, Ord)
|
||||
|
||||
data LeafProject = LeafProject | LeafProjectFollowers deriving (Eq, Ord)
|
||||
|
||||
data PieceDeck
|
||||
= PieceDeck LeafDeck
|
||||
| PieceTicket (KeyHashid TicketDeck) LeafTicket
|
||||
|
|
@ -444,6 +461,7 @@ data LocalRecipient
|
|||
| RecipRepo (KeyHashid Repo) LeafRepo
|
||||
| RecipDeck (KeyHashid Deck) PieceDeck
|
||||
| RecipLoom (KeyHashid Loom) PieceLoom
|
||||
| RecipProject (KeyHashid Project) LeafProject
|
||||
deriving (Eq, Ord)
|
||||
|
||||
recipientFromActor :: LocalActor -> LocalRecipient
|
||||
|
|
@ -457,6 +475,8 @@ recipientFromActor (LocalActorDeck dkhid) =
|
|||
RecipDeck dkhid $ PieceDeck LeafDeck
|
||||
recipientFromActor (LocalActorLoom lkhid) =
|
||||
RecipLoom lkhid $ PieceLoom LeafLoom
|
||||
recipientFromActor (LocalActorProject jkhid) =
|
||||
RecipProject jkhid LeafProject
|
||||
|
||||
recipientFromStage :: LocalStage -> LocalRecipient
|
||||
recipientFromStage (LocalStagePersonFollowers pkhid) =
|
||||
|
|
@ -473,6 +493,8 @@ recipientFromStage (LocalStageLoomFollowers lkhid) =
|
|||
RecipLoom lkhid $ PieceLoom LeafLoomFollowers
|
||||
recipientFromStage (LocalStageClothFollowers lkhid ltkhid) =
|
||||
RecipLoom lkhid $ PieceCloth ltkhid LeafClothFollowers
|
||||
recipientFromStage (LocalStageProjectFollowers jkhid) =
|
||||
RecipProject jkhid LeafProjectFollowers
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Recipient set types
|
||||
|
|
@ -493,19 +515,22 @@ groupLocalRecipients = organize . partitionByActor
|
|||
, [(KeyHashid Repo, LeafRepo)]
|
||||
, [(KeyHashid Deck, PieceDeck)]
|
||||
, [(KeyHashid Loom, PieceLoom)]
|
||||
, [(KeyHashid Project, LeafProject)]
|
||||
)
|
||||
partitionByActor = foldl' f ([], [], [], [], [])
|
||||
partitionByActor = foldl' f ([], [], [], [], [], [])
|
||||
where
|
||||
f (p, g, r, d, l) (RecipPerson pkhid pleaf) =
|
||||
((pkhid, pleaf) : p, g, r, d, l)
|
||||
f (p, g, r, d, l) (RecipGroup gkhid gleaf) =
|
||||
(p, (gkhid, gleaf) : g, r, d, l)
|
||||
f (p, g, r, d, l) (RecipRepo rkhid rleaf) =
|
||||
(p, g, (rkhid, rleaf) : r, d, l)
|
||||
f (p, g, r, d, l) (RecipDeck dkhid dpiece) =
|
||||
(p, g, r, (dkhid, dpiece) : d, l)
|
||||
f (p, g, r, d, l) (RecipLoom lkhid lpiece) =
|
||||
(p, g, r, d, (lkhid, lpiece) : l)
|
||||
f (p, g, r, d, l, j) (RecipPerson pkhid pleaf) =
|
||||
((pkhid, pleaf) : p, g, r, d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipGroup gkhid gleaf) =
|
||||
(p, (gkhid, gleaf) : g, r, d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipRepo rkhid rleaf) =
|
||||
(p, g, (rkhid, rleaf) : r, d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipDeck dkhid dpiece) =
|
||||
(p, g, r, (dkhid, dpiece) : d, l, j)
|
||||
f (p, g, r, d, l, j) (RecipLoom lkhid lpiece) =
|
||||
(p, g, r, d, (lkhid, lpiece) : l, j)
|
||||
f (p, g, r, d, l, j) (RecipProject jkhid jleaf) =
|
||||
(p, g, r, d, l, (jkhid, jleaf) : j)
|
||||
|
||||
organize
|
||||
:: ( [(KeyHashid Person, LeafPerson)]
|
||||
|
|
@ -513,9 +538,10 @@ groupLocalRecipients = organize . partitionByActor
|
|||
, [(KeyHashid Repo, LeafRepo)]
|
||||
, [(KeyHashid Deck, PieceDeck)]
|
||||
, [(KeyHashid Loom, PieceLoom)]
|
||||
, [(KeyHashid Project, LeafProject)]
|
||||
)
|
||||
-> RecipientRoutes
|
||||
organize (p, g, r, d, l) = RecipientRoutes
|
||||
organize (p, g, r, d, l, j) = RecipientRoutes
|
||||
{ recipPeople =
|
||||
map (second $ foldr orLP $ PersonRoutes False False) $ groupByKeySort p
|
||||
, recipGroups =
|
||||
|
|
@ -544,6 +570,8 @@ groupLocalRecipients = organize . partitionByActor
|
|||
. partitionEithers . NE.toList . NE.map pl2either
|
||||
) $
|
||||
groupByKeySort l
|
||||
, recipProjects =
|
||||
map (second $ foldr orLJ $ ProjectRoutes False False) $ groupByKeySort j
|
||||
}
|
||||
where
|
||||
groupByKey :: (Foldable f, Eq a) => f (a, b) -> [(a, NonEmpty b)]
|
||||
|
|
@ -585,6 +613,11 @@ groupLocalRecipients = organize . partitionByActor
|
|||
orLC _ cr@(ClothRoutes True) = cr
|
||||
orLC LeafClothFollowers cr@(ClothRoutes _) = cr { routeClothFollowers = True }
|
||||
|
||||
orLJ :: LeafProject -> ProjectRoutes -> ProjectRoutes
|
||||
orLJ _ rr@(ProjectRoutes True True) = rr
|
||||
orLJ LeafProject rr@(ProjectRoutes _ _) = rr { routeProject = True }
|
||||
orLJ LeafProjectFollowers rr@(ProjectRoutes _ _) = rr { routeProjectFollowers = True }
|
||||
|
||||
pd2either :: PieceDeck -> Either LeafDeck (KeyHashid TicketDeck, LeafTicket)
|
||||
pd2either (PieceDeck ld) = Left ld
|
||||
pd2either (PieceTicket ltkhid lt) = Right (ltkhid, lt)
|
||||
|
|
@ -622,6 +655,7 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
|
|||
, recipRepos = applySieve' applyRepo recipRepos
|
||||
, recipDecks = applySieve' applyDeck recipDecks
|
||||
, recipLooms = applySieve' applyLoom recipLooms
|
||||
, recipProjects = applySieve' applyProject recipProjects
|
||||
}
|
||||
where
|
||||
applySieve
|
||||
|
|
@ -725,6 +759,17 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
|
|||
then Nothing
|
||||
else Just (lkhid, LoomFamilyRoutes loom cloths)
|
||||
|
||||
applyProject _ (This _) = Nothing
|
||||
applyProject rkhid (That r) =
|
||||
if allowOthers && routeProject r
|
||||
then Just (rkhid, ProjectRoutes True False)
|
||||
else Nothing
|
||||
applyProject rkhid (These (ProjectRoutes r' rf') (ProjectRoutes r rf)) =
|
||||
let merged = ProjectRoutes (r && (r' || allowOthers)) (rf && rf')
|
||||
in if merged == ProjectRoutes False False
|
||||
then Nothing
|
||||
else Just (rkhid, merged)
|
||||
|
||||
actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
|
||||
actorIsAddressed recips = isJust . verify
|
||||
where
|
||||
|
|
@ -743,6 +788,9 @@ actorIsAddressed recips = isJust . verify
|
|||
verify (LocalActorLoom l) = do
|
||||
routes <- lookup l $ recipLooms recips
|
||||
guard $ routeLoom $ familyLoom routes
|
||||
verify (LocalActorProject j) = do
|
||||
routes <- lookup j $ recipProjects recips
|
||||
guard $ routeProject routes
|
||||
|
||||
data ParsedAudience u = ParsedAudience
|
||||
{ paudLocalRecips :: RecipientRoutes
|
||||
|
|
|
|||
|
|
@ -378,6 +378,8 @@ getLocalActors actorIDs = do
|
|||
selectKeysList [DeckActor <-. actorIDs] []
|
||||
, map LocalActorLoom <$>
|
||||
selectKeysList [LoomActor <-. actorIDs] []
|
||||
, map LocalActorProject <$>
|
||||
selectKeysList [ProjectActor <-. actorIDs] []
|
||||
]
|
||||
case compare (length localActors) (length actorIDs) of
|
||||
LT -> error "Found actor ID not used by any specific actor"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -16,6 +16,7 @@
|
|||
module Vervis.Widget.Tracker
|
||||
( deckNavW
|
||||
, loomNavW
|
||||
, projectNavW
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -38,3 +39,8 @@ loomNavW (Entity loomID loom) actor = do
|
|||
loomHash <- encodeKeyHashid loomID
|
||||
hashRepo <- getEncodeKeyHashid
|
||||
$(widgetFile "loom/widget/nav")
|
||||
|
||||
projectNavW :: Entity Project -> Actor -> Widget
|
||||
projectNavW (Entity projectID project) actor = do
|
||||
projectHash <- encodeKeyHashid projectID
|
||||
$(widgetFile "project/widget/nav")
|
||||
|
|
|
|||
|
|
@ -1715,6 +1715,7 @@ data CreateObject u
|
|||
| CreateTicketTracker ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||
| CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u))
|
||||
| CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u))
|
||||
| CreateProject ActorDetail (Maybe (Authority u, ActorLocal u))
|
||||
|
||||
parseCreateObject :: UriMode u => Object -> Parser (CreateObject u)
|
||||
parseCreateObject o
|
||||
|
|
@ -1737,6 +1738,11 @@ parseCreateObject o
|
|||
repos <- o .:*+ "tracksPatchesFor"
|
||||
ml <- parseActorLocal o
|
||||
return $ CreatePatchTracker d repos ml
|
||||
<|> do d <- parseActorDetail o
|
||||
unless (actorType d == ActorTypeProject) $
|
||||
fail "type isn't Project"
|
||||
ml <- parseActorLocal o
|
||||
return $ CreateProject d ml
|
||||
|
||||
encodeCreateObject :: UriMode u => CreateObject u -> Series
|
||||
encodeCreateObject (CreateNote h note) = toSeries h note
|
||||
|
|
@ -1751,6 +1757,8 @@ encodeCreateObject (CreatePatchTracker d repos ml)
|
|||
= encodeActorDetail d
|
||||
<> "tracksPatchesFor" .=*+ repos
|
||||
<> maybe mempty (uncurry encodeActorLocal) ml
|
||||
encodeCreateObject (CreateProject d ml) =
|
||||
encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml
|
||||
|
||||
data Create u = Create
|
||||
{ createObject :: CreateObject u
|
||||
|
|
@ -1770,6 +1778,7 @@ parseCreate o a luActor = do
|
|||
CreateTicketTracker _ _ -> return ()
|
||||
CreateRepository _ _ _ -> return ()
|
||||
CreatePatchTracker _ _ _ -> return ()
|
||||
CreateProject _ _ -> return ()
|
||||
Create obj <$> o .:? "target"
|
||||
|
||||
encodeCreate :: UriMode u => Create u -> Series
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$# Written in 2016, 2018, 2019, 2022, 2023
|
||||
$# by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
|
|
@ -96,3 +97,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<li>
|
||||
<a href=@{LoomR $ hashLoom loomID}>
|
||||
+#{keyHashidText $ hashLoom loomID} #{actorName actor}
|
||||
|
||||
<h2>Projects
|
||||
|
||||
<ul>
|
||||
$forall (Entity projectID _, Entity _ actor) <- projects
|
||||
<li>
|
||||
<a href=@{ProjectR $ hashProject projectID}>
|
||||
$#{keyHashidText $ hashProject projectID} #{actorName actor}
|
||||
$# #{abcde}
|
||||
|
|
|
|||
|
|
@ -33,6 +33,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<li>
|
||||
<a href=@{LoomNewR}>
|
||||
Create a new patch tracker
|
||||
<li>
|
||||
<a href=@{ProjectNewR}>
|
||||
Create a new project
|
||||
<li>
|
||||
<a href=@{PublishOfferMergeR}>
|
||||
Open a merge request
|
||||
|
|
@ -85,3 +88,14 @@ $# Comment on a ticket or merge request
|
|||
]
|
||||
<a href=@{LoomR $ hashLoom loomID}>
|
||||
+#{keyHashidText $ hashLoom loomID} #{actorName actor}
|
||||
|
||||
<h2>Your projects
|
||||
|
||||
<ul>
|
||||
$forall (Entity projectID _, Entity _ actor, Entity _ (Collab role)) <- projects
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{ProjectR $ hashProject projectID}>
|
||||
$#{keyHashidText $ hashProject projectID} #{actorName actor}
|
||||
|
|
|
|||
59
templates/project/collab/list.hamlet
Normal file
59
templates/project/collab/list.hamlet
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ 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
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
^{projectNavW (Entity projectID project) actor}
|
||||
|
||||
<h2>Collaborators
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Role
|
||||
<th>Collaborator
|
||||
<th>Since
|
||||
$forall (person, role, ctID, since) <- collabs
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>^{personLinkFedW person}
|
||||
<td>#{showDate since}
|
||||
<td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
|
||||
|
||||
<h2>Invites
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Inviter
|
||||
<th>Invitee
|
||||
<th>Role
|
||||
<th>Time
|
||||
$forall (inviter, invitee, time, role) <- invites
|
||||
<tr>
|
||||
<td>^{personLinkFedW inviter}
|
||||
<td>^{personLinkFedW invitee}
|
||||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
|
||||
<a href=@{ProjectInviteR projectHash}>Invite…
|
||||
|
||||
<h2>Joins
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Joiner
|
||||
<th>Role
|
||||
<th>Time
|
||||
$forall (joiner, time, role) <- joins
|
||||
<tr>
|
||||
<td>^{personLinkFedW joiner}
|
||||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
18
templates/project/collab/new.hamlet
Normal file
18
templates/project/collab/new.hamlet
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ 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
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
<form method=POST action=@{ProjectInviteR projectHash} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<div class="submit">
|
||||
<input type="submit">
|
||||
18
templates/project/new.hamlet
Normal file
18
templates/project/new.hamlet
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ 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
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
<form method=POST action=@{ProjectNewR} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<div class="submit">
|
||||
<input type="submit">
|
||||
36
templates/project/widget/nav.hamlet
Normal file
36
templates/project/widget/nav.hamlet
Normal file
|
|
@ -0,0 +1,36 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ 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
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
<div>
|
||||
<span>
|
||||
[[ 🏗
|
||||
<a href=@{ProjectR projectHash}>
|
||||
$#{keyHashidText projectHash} #{actorName actor}
|
||||
]] ::
|
||||
<span>
|
||||
<a href=@{ProjectInboxR projectHash}>
|
||||
[📥 Inbox]
|
||||
<span>
|
||||
<a href=@{ProjectOutboxR projectHash}>
|
||||
[📤 Outbox]
|
||||
<span>
|
||||
<a href=@{ProjectFollowersR projectHash}>
|
||||
[🐤 Followers]
|
||||
<span>
|
||||
<a href=@{ProjectCollabsR projectHash}>
|
||||
[🤝 Collaborators]
|
||||
<span>
|
||||
[No wiki]
|
||||
<span>
|
||||
[✏ Edit]
|
||||
13
th/models
13
th/models
|
|
@ -647,13 +647,6 @@ CollabRecipRemoteJoin
|
|||
|
||||
-------------------------------- Collab topic --------------------------------
|
||||
|
||||
-- Removed for now, until I figure out whether/how to federate custom roles
|
||||
--CollabRoleLocal
|
||||
-- collab CollabId
|
||||
-- role RoleId
|
||||
--
|
||||
-- UniqueCollabRoleLocal collab
|
||||
|
||||
CollabTopicRepo
|
||||
collab CollabId
|
||||
repo RepoId
|
||||
|
|
@ -672,6 +665,12 @@ CollabTopicLoom
|
|||
|
||||
UniqueCollabTopicLoom collab
|
||||
|
||||
CollabTopicProject
|
||||
collab CollabId
|
||||
project ProjectId
|
||||
|
||||
UniqueCollabTopicProject collab
|
||||
|
||||
CollabEnable
|
||||
collab CollabId
|
||||
grant OutboxItemId
|
||||
|
|
|
|||
18
th/routes
18
th/routes
|
|
@ -304,3 +304,21 @@
|
|||
|
||||
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/new-dep ClothDepNewR GET POST
|
||||
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/deps/#TicketDepKeyHashid/delete ClothDepDeleteR POST
|
||||
|
||||
---- Project -----------------------------------------------------------------
|
||||
|
||||
/projects/#ProjectKeyHashid ProjectR GET
|
||||
/projects/#ProjectKeyHashid/inbox ProjectInboxR GET POST
|
||||
/projects/#ProjectKeyHashid/outbox ProjectOutboxR GET
|
||||
/projects/#ProjectKeyHashid/outbox/#OutboxItemKeyHashid ProjectOutboxItemR GET
|
||||
/projects/#ProjectKeyHashid/followers ProjectFollowersR GET
|
||||
|
||||
/projects/#ProjectKeyHashid/messages/#LocalMessageKeyHashid ProjectMessageR GET
|
||||
|
||||
/new-project ProjectNewR GET POST
|
||||
|
||||
/projects/#ProjectKeyHashid/stamps/#SigKeyKeyHashid ProjectStampR GET
|
||||
|
||||
/projects/#ProjectKeyHashid/collabs ProjectCollabsR GET
|
||||
/projects/#ProjectKeyHashid/invite ProjectInviteR GET POST
|
||||
/projects/#ProjectKeyHashid/remove/#CollabTopicProjectId ProjectRemoveR POST
|
||||
|
|
|
|||
|
|
@ -149,6 +149,7 @@ library
|
|||
Vervis.Actor.Loom
|
||||
Vervis.Actor.Person
|
||||
Vervis.Actor.Person.Client
|
||||
Vervis.Actor.Project
|
||||
Vervis.Actor.Repo
|
||||
Vervis.API
|
||||
Vervis.Avatar
|
||||
|
|
@ -210,6 +211,7 @@ library
|
|||
Vervis.Handler.Person
|
||||
Vervis.Handler.Repo
|
||||
--Vervis.Handler.Role
|
||||
Vervis.Handler.Project
|
||||
--Vervis.Handler.Sharer
|
||||
Vervis.Handler.Ticket
|
||||
-- Vervis.Handler.Wiki
|
||||
|
|
|
|||
Loading…
Reference in a new issue