forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Switch to more flexible collaborator model

Browse source
This commit is contained in:
fr33domlover 2022-06-22 06:19:37 +00:00
parent bf2e172f6e
commit bfa9774f83
13 changed files with 504 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
config/models
View file

@ -1,6 +1,7 @@
-- This file is part of Vervis. -- This file is part of Vervis.
-- --
-- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. -- Written in 2016, 2018, 2019, 2020, 2022
-- by fr33domlover <fr33domlover@riseup.net>.
-- --
-- ♡ Copying is an act of love. Please copy, reuse and share. -- ♡ Copying is an act of love. Please copy, reuse and share.
-- --
@ -572,16 +573,67 @@ RemoteMessage
UniqueRemoteMessage rest UniqueRemoteMessage rest
UniqueRemoteMessageCreate create UniqueRemoteMessageCreate create
RepoCollab
------------------------------------------------------------------------------
-- Collaborators
------------------------------------------------------------------------------
Collab
-------------------------------- Collab topic --------------------------------
CollabRoleLocal
collab CollabId
role RoleId
UniqueCollabRoleLocal collab
CollabTopicLocalRepo
collab CollabId
repo RepoId repo RepoId
person PersonId
role RoleId Maybe
UniqueRepoCollab repo person UniqueCollabTopicLocalRepo collab
ProjectCollab CollabTopicLocalProject
collab CollabId
project ProjectId project ProjectId
person PersonId
role RoleId Maybe
UniqueProjectCollab project person UniqueCollabTopicLocalProject collab
CollabTopicRemote
collab CollabId
topic RemoteObjectId
role LocalURI Maybe
UniqueCollabTopicRemote collab
-------------------------------- Collab sender -------------------------------
CollabSenderLocal
collab CollabId
activity OutboxItemId
UniqueCollabSenderLocal collab
UniqueCollabSenderLocalActivity activity
CollabSenderRemote
collab CollabId
actor RemoteActorId
activity RemoteActivityId
UniqueCollabSenderRemote collab
UniqueCollabSenderRemoteActivity activity
-------------------------------- Collab recipient ----------------------------
CollabRecipLocal
collab CollabId
person PersonId
UniqueCollabRecipLocal collab
CollabRecipRemote
collab CollabId
actor RemoteActorId
UniqueCollabRecipRemote collab

59
migrations/2022_06_14_collab.model Normal file
View file

@ -0,0 +1,59 @@
Collab
CollabRoleLocal
collab CollabId
role RoleId
UniqueCollabRoleLocal collab
CollabTopicLocalRepo
collab CollabId
repo RepoId
UniqueCollabTopicLocalRepo collab
CollabTopicLocalProject
collab CollabId
project ProjectId
UniqueCollabTopicLocalProject collab
CollabTopicRemote
collab CollabId
topic RemoteObjectId
role LocalURI Maybe
UniqueCollabTopicRemote collab
CollabSenderLocal
collab CollabId
activity OutboxItemId
UniqueCollabSenderLocal collab
UniqueCollabSenderLocalActivity activity
CollabSenderRemote
collab CollabId
actor RemoteActorId
activity RemoteActivityId
UniqueCollabSenderRemote collab
UniqueCollabSenderRemoteActivity activity
CollabRecipLocal
collab CollabId
person PersonId
UniqueCollabRecipLocal collab
CollabRecipRemote
collab CollabId
actor RemoteActorId
UniqueCollabRecipRemote collab

94
migrations/2022_06_14_collab_mig.model Normal file
View file

@ -0,0 +1,94 @@
Outbox
OutboxItem
outbox OutboxId
activity PersistJSONObject
published UTCTime
Person
Project
ident PrjIdent
sharer Int64
name Text Maybe
desc Text Maybe
workflow Int64
nextTicket Int
wiki RepoId Maybe
collabUser RoleId Maybe
collabAnon RoleId Maybe
inbox Int64
outbox OutboxId
followers Int64
Repo
ident RpIdent
sharer Int64
vcs VersionControlSystem
project ProjectId Maybe
desc Text Maybe
mainBranch Text
collabUser RoleId Maybe
collabAnon RoleId Maybe
inbox Int64
outbox OutboxId
followers Int64
Role
Collab
CollabRoleLocal
collab CollabId
role RoleId
UniqueCollabRoleLocal collab
CollabTopicLocalRepo
collab CollabId
repo RepoId
UniqueCollabTopicLocalRepo collab
CollabTopicLocalProject
collab CollabId
project ProjectId
UniqueCollabTopicLocalProject collab
CollabSenderLocal
collab CollabId
activity OutboxItemId
UniqueCollabSenderLocal collab
UniqueCollabSenderLocalActivity activity
CollabRecipLocal
collab CollabId
person PersonId
UniqueCollabRecipLocal collab
RepoCollab
repo RepoId
person PersonId
role RoleId Maybe
UniqueRepoCollab repo person
ProjectCollab
project ProjectId
person PersonId
role RoleId Maybe
UniqueProjectCollab project person

38
src/Vervis/Access.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -63,11 +63,13 @@ import Control.Applicative ((<|>))
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Maybe (fromMaybe, isJust) import Data.Maybe
import Database.Persist.Class (getBy) import Database.Persist.Class (getBy)
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)
import Database.Persist.Types (Entity (..)) import Database.Persist.Types (Entity (..))
import qualified Database.Esqueleto as E
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Role import Vervis.Model.Role
@ -132,9 +134,19 @@ checkRepoAccess mpid op shr rp = do
Nothing -> pure $ fromMaybe Guest $ asAnon repo Nothing -> pure $ fromMaybe Guest $ asAnon repo
status <$> roleHasAccess role op status <$> roleHasAccess role op
where where
asCollab rid pid = asCollab rid pid = do
fmap (maybe Developer RoleID . repoCollabRole . entityVal) <$> fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do
getBy (UniqueRepoCollab rid pid) E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.LeftOuterJoin` role) -> do
E.on $ E.just (topic E.^. CollabTopicLocalRepoCollab) E.==. role E.?. CollabRoleLocalCollab
E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&.
recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1
return
( topic E.^. CollabTopicLocalRepoCollab
, role E.?. CollabRoleLocalRole
)
asUser = fmap RoleID . repoCollabUser asUser = fmap RoleID . repoCollabUser
asAnon = fmap RoleID . repoCollabAnon asAnon = fmap RoleID . repoCollabAnon
@ -160,8 +172,18 @@ checkProjectAccess mpid op shr prj = do
Nothing -> pure $ fromMaybe Guest $ asAnon project Nothing -> pure $ fromMaybe Guest $ asAnon project
status <$> roleHasAccess role op status <$> roleHasAccess role op
where where
asCollab jid pid = asCollab jid pid = do
fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$> fmap (maybe Developer RoleID . E.unValue . snd) . listToMaybe <$> do
getBy (UniqueProjectCollab jid pid) E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.LeftOuterJoin` role) -> do
E.on $ E.just (topic E.^. CollabTopicLocalProjectCollab) E.==. role E.?. CollabRoleLocalCollab
E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. CollabTopicLocalProjectProject E.==. E.val jid E.&&.
recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1
return
( topic E.^. CollabTopicLocalProjectCollab
, role E.?. CollabRoleLocalRole
)
asUser = fmap RoleID . projectCollabUser asUser = fmap RoleID . projectCollabUser
asAnon = fmap RoleID . projectCollabAnon asAnon = fmap RoleID . projectCollabAnon

12
src/Vervis/ActivityPub.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -1124,7 +1124,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
(localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts) (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
] ]
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
pids <- map (projectCollabPerson . entityVal) <$> selectList [ProjectCollabProject <-. jids] [] pids <- fmap (map E.unValue) $ E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
E.where_ $ topic E.^. CollabTopicLocalProjectProject `E.in_` E.valList jids
return $ recip E.^. CollabRecipLocalPerson
map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox]
getRepoTeams sid repos = do getRepoTeams sid repos = do
let rps = let rps =
@ -1134,7 +1137,10 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor reci
(localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp)) (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp))
] ]
rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] [] rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] [] pids <- fmap (map E.unValue) $ E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
E.where_ $ topic E.^. CollabTopicLocalRepoRepo `E.in_` E.valList rids
return $ recip E.^. CollabRecipLocalPerson
map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox]
-- | Given a list of local recipients, which may include actors and -- | Given a list of local recipients, which may include actors and

46
src/Vervis/Field/Repo.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -72,12 +72,11 @@ mkIdentField sid = checkIdentUnique sid . checkIdentTemplate $ textField
selectCollabFromAll :: RepoId -> Field Handler PersonId selectCollabFromAll :: RepoId -> Field Handler PersonId
selectCollabFromAll rid = selectField $ do selectCollabFromAll rid = selectField $ do
l <- runDB $ select $ l <- runDB $ select $
from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do from $ \ (person `InnerJoin` sharer `LeftOuterJoin` (recip `InnerJoin` topic)) -> do
on $ person ^. PersonIdent ==. sharer ^. SharerId on $ recip ^. CollabRecipLocalCollab ==. topic ^. CollabTopicLocalRepoCollab &&. topic ^. CollabTopicLocalRepoRepo ==. val rid
on $ on $ person ^. PersonId ==. recip ^. CollabRecipLocalPerson
collab ?. RepoCollabRepo ==. just (val rid) &&. on $ person ^. PersonIdent ==. sharer ^. SharerId
collab ?. RepoCollabPerson ==. just (person ^. PersonId) where_ $ isNothing $ just $ recip ^. CollabRecipLocalId
where_ $ isNothing $ collab ?. RepoCollabId
return (sharer ^. SharerIdent, person ^. PersonId) return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (bimap (shr2text . unValue) unValue) l optionsPairs $ map (bimap (shr2text . unValue) unValue) l
@ -87,19 +86,15 @@ selectCollabFromAll rid = selectField $ do
selectCollabFromProject :: ProjectId -> RepoId -> Field Handler PersonId selectCollabFromProject :: ProjectId -> RepoId -> Field Handler PersonId
selectCollabFromProject jid rid = selectField $ do selectCollabFromProject jid rid = selectField $ do
l <- runDB $ select $ from $ l <- runDB $ select $ from $
\ ( pcollab `InnerJoin` \ (topic `InnerJoin` recip `InnerJoin` person `InnerJoin` sharer `LeftOuterJoin` (recipR `InnerJoin` topicR)) -> do
person `LeftOuterJoin` on $ recipR ^. CollabRecipLocalCollab ==. topicR ^. CollabTopicLocalRepoCollab &&.
rcollab `InnerJoin` topicR ^. CollabTopicLocalRepoRepo ==. val rid
sharer on $ person ^. PersonId ==. recipR ^. CollabRecipLocalPerson
) -> do
on $ person ^. PersonIdent ==. sharer ^. SharerId on $ person ^. PersonIdent ==. sharer ^. SharerId
on $ on $ recip ^. CollabRecipLocalPerson ==. person ^. PersonId
rcollab ?. RepoCollabRepo ==. just (val rid) &&. on $ topic ^. CollabTopicLocalProjectCollab ==. recip ^. CollabRecipLocalCollab &&.
rcollab ?. RepoCollabPerson ==. just (person ^. PersonId) topic ^. CollabTopicLocalProjectProject ==. val jid
on $ where_ $ isNothing $ just $ recipR ^. CollabRecipLocalId
pcollab ^. ProjectCollabProject ==. val jid &&.
pcollab ^. ProjectCollabPerson ==. person ^. PersonId
where_ $ isNothing $ rcollab ?. RepoCollabId
return (sharer ^. SharerIdent, person ^. PersonId) return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (bimap (shr2text . unValue) unValue) l optionsPairs $ map (bimap (shr2text . unValue) unValue) l
@ -126,12 +121,13 @@ selectProjectForExisting :: SharerId -> RepoId -> Field Handler ProjectId
selectProjectForExisting sid rid = checkMembers $ selectProjectForNew sid selectProjectForExisting sid rid = checkMembers $ selectProjectForNew sid
where where
checkMembers = checkM $ \ jid -> do checkMembers = checkM $ \ jid -> do
l <- runDB $ select $ from $ \ (rc `LeftOuterJoin` pc) -> do l <- runDB $ select $ from $ \ (recipR `InnerJoin` topicR `LeftOuterJoin` (recipJ `InnerJoin` topicJ)) -> do
on $ on $ topicJ ^. CollabTopicLocalProjectProject ==. val jid &&.
rc ^. RepoCollabRepo ==. val rid &&. recipJ ^. CollabRecipLocalCollab ==. topicJ ^. CollabTopicLocalProjectCollab
pc ?. ProjectCollabProject ==. just (val jid) &&. on $ recipR ^. CollabRecipLocalPerson ==. recipJ ^. CollabRecipLocalPerson
pc ?. ProjectCollabPerson ==. just (rc ^. RepoCollabPerson) on $ topicR ^. CollabTopicLocalRepoRepo ==. val rid &&.
where_ $ isNothing $ pc ?. ProjectCollabId recipR ^. CollabRecipLocalCollab ==. topicR ^. CollabTopicLocalRepoCollab
where_ $ isNothing $ just $ recipJ ^. CollabRecipLocalId
limit 1 limit 1
return () return ()
return $ if null l return $ if null l

11
src/Vervis/Field/Ticket.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -43,12 +43,13 @@ import Vervis.Model.Ident (shr2text)
selectAssigneeFromProject :: PersonId -> ProjectId -> Field Handler PersonId selectAssigneeFromProject :: PersonId -> ProjectId -> Field Handler PersonId
selectAssigneeFromProject pid jid = selectField $ do selectAssigneeFromProject pid jid = selectField $ do
l <- runDB $ select $ from $ l <- runDB $ select $ from $
\ (pcollab `InnerJoin` person `InnerJoin` sharer) -> do \ (topic `InnerJoin` recip `InnerJoin` person `InnerJoin` sharer) -> do
on $ person ^. PersonIdent ==. sharer ^. SharerId on $ person ^. PersonIdent ==. sharer ^. SharerId
on $ pcollab ^. ProjectCollabPerson ==. person ^. PersonId on $ recip ^. CollabRecipLocalPerson ==. person ^. PersonId
on $ topic ^. CollabTopicLocalProjectCollab ==. recip ^. CollabRecipLocalCollab
where_ $ where_ $
pcollab ^. ProjectCollabProject ==. val jid &&. topic ^. CollabTopicLocalProjectProject ==. val jid &&.
person ^. PersonId !=. val pid person ^. PersonId !=. val pid
return (sharer ^. SharerIdent, person ^. PersonId) return (sharer ^. SharerIdent, person ^. PersonId)
optionsPairs $ map (shr2text . unValue *** unValue) l optionsPairs $ map (shr2text . unValue *** unValue) l

20
src/Vervis/Form/Project.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -94,15 +94,15 @@ newProjectCollabAForm sid jid = NewProjectCollab
<*> aopt selectRole "Custom role" Nothing <*> aopt selectRole "Custom role" Nothing
where where
selectPerson = selectField $ do selectPerson = selectField $ do
l <- runDB $ select $ l <- runDB $ E.select $
from $ \ (collab `RightOuterJoin` person `InnerJoin` sharer) -> do E.from $ \ (person `E.InnerJoin` sharer `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
on $ person ^. PersonIdent E.==. sharer ^. SharerId E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalProjectCollab E.&&.
on $ topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
collab ?. ProjectCollabProject E.==. just (val jid) &&. E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
collab ?. ProjectCollabPerson E.==. just (person ^. PersonId) E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
where_ $ E.isNothing $ collab ?. ProjectCollabId E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
return (sharer ^. SharerIdent, person ^. PersonId) return (sharer E.^. SharerIdent, person E.^. PersonId)
optionsPairs $ map (bimap (shr2text . unValue) unValue) l optionsPairs $ map (bimap (shr2text . E.unValue) E.unValue) l
selectRole = selectRole =
selectField $ selectField $
optionsPersistKey [RoleSharer ==. sid] [] $ optionsPersistKey [RoleSharer ==. sid] [] $

108
src/Vervis/Handler/Project.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -32,8 +32,11 @@ module Vervis.Handler.Project
) )
where where
import Data.Foldable
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist import Database.Persist
import Database.Esqueleto hiding (delete, (%), (==.)) import Database.Esqueleto hiding (delete, (%), (==.))
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
@ -46,10 +49,12 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Project (..), Repo (..)) import Web.ActivityPub hiding (Project (..), Repo (..))
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.MonadSite
import qualified Web.ActivityPub as AP import qualified Web.ActivityPub as AP
@ -85,6 +90,8 @@ postProjectsR shr = do
((result, widget), enctype) <- runFormPost $ newProjectForm sid ((result, widget), enctype) <- runFormPost $ newProjectForm sid
case result of case result of
FormSuccess np -> do FormSuccess np -> do
now <- liftIO getCurrentTime
host <- asksSite siteInstanceHost
pid <- requireAuthId pid <- requireAuthId
runDB $ do runDB $ do
ibid <- insert Inbox ibid <- insert Inbox
@ -105,12 +112,18 @@ postProjectsR shr = do
, projectFollowers = fsid , projectFollowers = fsid
} }
jid <- insert project jid <- insert project
let collab = ProjectCollab
{ projectCollabProject = jid obiid <-
, projectCollabPerson = pid insert $
, projectCollabRole = npRole np OutboxItem
} obid
insert_ collab (persistJSONObjectFromDoc $ Doc host emptyActivity)
now
cid <- insert Collab
for_ (npRole np) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
insert_ $ CollabTopicLocalProject cid jid
insert_ $ CollabSenderLocal cid obiid
insert_ $ CollabRecipLocal cid pid
setMessage "Project added." setMessage "Project added."
redirect $ ProjectR shr (npIdent np) redirect $ ProjectR shr (npIdent np)
FormMissing -> do FormMissing -> do
@ -212,33 +225,39 @@ getProjectDevsR shr prj = do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
return jid return jid
select $ from $ \ (collab `InnerJoin` E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do
person `InnerJoin` E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId
sharer `LeftOuterJoin` E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab
role) -> do E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
on $ collab ^. ProjectCollabRole E.==. role ?. RoleId E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
on $ person ^. PersonIdent E.==. sharer ^. SharerId E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
on $ collab ^. ProjectCollabPerson E.==. person ^. PersonId E.where_ $ topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
where_ $ collab ^. ProjectCollabProject E.==. val jid return (sharer, role E.?. RoleIdent)
return (sharer, role ?. RoleIdent)
defaultLayout $(widgetFile "project/collab/list") defaultLayout $(widgetFile "project/collab/list")
postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
postProjectDevsR shr rp = do postProjectDevsR shr rp = do
(sid, jid) <- runDB $ do (sid, jid, obid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject rp s Entity jid j <- getBy404 $ UniqueProject rp sid
return (s, j) return (sid, jid, projectOutbox j)
((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid ((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
case result of case result of
FormSuccess nc -> do FormSuccess nc -> do
now <- liftIO getCurrentTime
host <- asksSite siteInstanceHost
runDB $ do runDB $ do
let collab = ProjectCollab obiid <-
{ projectCollabProject = jid insert $
, projectCollabPerson = ncPerson nc OutboxItem
, projectCollabRole = ncRole nc obid
} (persistJSONObjectFromDoc $ Doc host emptyActivity)
insert_ collab now
cid <- insert Collab
for_ (ncRole nc) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
insert_ $ CollabTopicLocalProject cid jid
insert_ $ CollabSenderLocal cid obiid
insert_ $ CollabRecipLocal cid (ncPerson nc)
setMessage "Collaborator added." setMessage "Collaborator added."
redirect $ ProjectDevsR shr rp redirect $ ProjectDevsR shr rp
FormMissing -> do FormMissing -> do
@ -268,8 +287,20 @@ getProjectDevR shr prj dev = do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
fmap roleIdent <$> traverse getJust (projectCollabRole collab) E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. CollabTopicLocalProjectProject E.==. E.val jid E.&&.
recip E.^. CollabRecipLocalPerson E.==. E.val pid
return $ recip E.^. CollabRecipLocalCollab
cid <-
case l of
[] -> notFound
[E.Value cid] -> return cid
_ -> error "Multiple collabs for project+person"
mcrole <- getValBy $ UniqueCollabRoleLocal cid
for mcrole $
\ (CollabRoleLocal _cid rlid) -> roleIdent <$> getJust rlid
defaultLayout $(widgetFile "project/collab/one") defaultLayout $(widgetFile "project/collab/one")
deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
@ -283,7 +314,26 @@ deleteProjectDevR shr rp dev = do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity cid _collab <- getBy404 $ UniqueProjectCollab jid pid collabs <- E.select $ E.from $ \ (recip `E.InnerJoin` topic) -> do
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalProjectCollab
E.where_ $
recip E.^. CollabRecipLocalPerson E.==. E.val pid E.&&.
topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
return
( recip E.^. CollabRecipLocalId
, topic E.^. CollabTopicLocalProjectId
, recip E.^. CollabRecipLocalCollab
)
(E.Value crid, E.Value ctid, E.Value cid) <-
case collabs of
[] -> notFound
[c] -> return c
_ -> error "More than 1 collab for project+person"
deleteWhere [CollabRoleLocalCollab ==. cid]
delete ctid
deleteWhere [CollabSenderLocalCollab ==. cid]
deleteWhere [CollabSenderRemoteCollab ==. cid]
delete crid
delete cid delete cid
setMessage "Collaborator removed." setMessage "Collaborator removed."
redirect $ ProjectDevsR shr rp redirect $ ProjectDevsR shr rp

100
src/Vervis/Handler/Repo.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2018, 2019, 2020, 2022
- by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -47,6 +48,7 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logWarn) import Control.Monad.Logger (logWarn)
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Bifunctor import Data.Bifunctor
import Data.Foldable
import Data.Git.Graph import Data.Git.Graph
import Data.Git.Harder import Data.Git.Harder
import Data.Git.Named (RefName (..)) import Data.Git.Named (RefName (..))
@ -61,6 +63,7 @@ import Data.List (inits)
import Data.Text (Text, unpack) import Data.Text (Text, unpack)
import Data.Text.Encoding import Data.Text.Encoding
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Data.Time.Clock
import Data.Traversable (for) import Data.Traversable (for)
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
@ -87,6 +90,7 @@ import qualified Data.Text.Lazy.Encoding as L (decodeUtf8With)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Data.MediaType import Data.MediaType
import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Repo (..), Project) import Web.ActivityPub hiding (Repo (..), Project)
import Yesod.ActivityPub import Yesod.ActivityPub
@ -143,6 +147,7 @@ postReposR user = do
((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing ((result, widget), enctype) <- runFormPost $ newRepoForm sid Nothing
case result of case result of
FormSuccess nrp -> do FormSuccess nrp -> do
now <- liftIO getCurrentTime
parent <- askSharerDir user parent <- askSharerDir user
liftIO $ createDirectoryIfMissing True parent liftIO $ createDirectoryIfMissing True parent
let repoName = let repoName =
@ -188,12 +193,18 @@ postReposR user = do
, repoFollowers = fsid , repoFollowers = fsid
} }
rid <- insert repo rid <- insert repo
let collab = RepoCollab
{ repoCollabRepo = rid obiid <-
, repoCollabPerson = pid insert $
, repoCollabRole = nrpRole nrp OutboxItem
} obid
insert_ collab (persistJSONObjectFromDoc $ Doc host emptyActivity)
now
cid <- insert Collab
for_ (nrpRole nrp) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
insert_ $ CollabTopicLocalRepo cid rid
insert_ $ CollabSenderLocal cid obiid
insert_ $ CollabRecipLocal cid pid
setMessage "Repo added." setMessage "Repo added."
redirect $ RepoR user (nrpIdent nrp) redirect $ RepoR user (nrpIdent nrp)
FormMissing -> do FormMissing -> do
@ -362,33 +373,39 @@ getRepoDevsR shr rp = do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity r _ <- getBy404 $ UniqueRepo rp s Entity r _ <- getBy404 $ UniqueRepo rp s
return r return r
E.select $ E.from $ \ (collab `E.InnerJoin` E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do
person `E.InnerJoin` E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId
sharer `E.LeftOuterJoin` E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab
role) -> do E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ collab E.^. RepoCollabRole E.==. role E.?. RoleId E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
E.on $ collab E.^. RepoCollabPerson E.==. person E.^. PersonId E.where_ $ topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid
E.where_ $ collab E.^. RepoCollabRepo E.==. E.val rid
return (sharer, role E.?. RoleIdent) return (sharer, role E.?. RoleIdent)
defaultLayout $(widgetFile "repo/collab/list") defaultLayout $(widgetFile "repo/collab/list")
postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html postRepoDevsR :: ShrIdent -> RpIdent -> Handler Html
postRepoDevsR shr rp = do postRepoDevsR shr rp = do
(sid, mjid, rid) <- runDB $ do (sid, mjid, obid, rid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity r repository <- getBy404 $ UniqueRepo rp s Entity r repository <- getBy404 $ UniqueRepo rp s
return (s, repoProject repository, r) return (s, repoProject repository, repoOutbox repository, r)
((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid ((result, widget), enctype) <- runFormPost $ newRepoCollabForm sid mjid rid
case result of case result of
FormSuccess nc -> do FormSuccess nc -> do
now <- liftIO getCurrentTime
host <- asksSite siteInstanceHost
runDB $ do runDB $ do
let collab = RepoCollab obiid <-
{ repoCollabRepo = rid insert $
, repoCollabPerson = ncPerson nc OutboxItem
, repoCollabRole = ncRole nc obid
} (persistJSONObjectFromDoc $ Doc host emptyActivity)
insert_ collab now
cid <- insert Collab
for_ (ncRole nc) $ \ rlid -> insert_ $ CollabRoleLocal cid rlid
insert_ $ CollabTopicLocalRepo cid rid
insert_ $ CollabSenderLocal cid obiid
insert_ $ CollabRecipLocal cid (ncPerson nc)
setMessage "Collaborator added." setMessage "Collaborator added."
redirect $ RepoDevsR shr rp redirect $ RepoDevsR shr rp
FormMissing -> do FormMissing -> do
@ -419,8 +436,20 @@ getRepoDevR shr rp dev = do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity _cid collab <- getBy404 $ UniqueRepoCollab rid pid l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
fmap roleIdent <$> traverse getJust (repoCollabRole collab) E.on $ topic E.^. CollabTopicLocalRepoCollab E.==. recip E.^. CollabRecipLocalCollab
E.where_ $
topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&.
recip E.^. CollabRecipLocalPerson E.==. E.val pid
return $ recip E.^. CollabRecipLocalCollab
cid <-
case l of
[] -> notFound
[E.Value cid] -> return cid
_ -> error "Multiple collabs for repo+person"
mcrole <- getValBy $ UniqueCollabRoleLocal cid
for mcrole $
\ (CollabRoleLocal _cid rlid) -> roleIdent <$> getJust rlid
defaultLayout $(widgetFile "repo/collab/one") defaultLayout $(widgetFile "repo/collab/one")
deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html deleteRepoDevR :: ShrIdent -> RpIdent -> ShrIdent -> Handler Html
@ -434,7 +463,26 @@ deleteRepoDevR shr rp dev = do
Entity s _ <- getBy404 $ UniqueSharer dev Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s Entity p _ <- getBy404 $ UniquePersonIdent s
return p return p
Entity cid _collab <- getBy404 $ UniqueRepoCollab rid pid collabs <- E.select $ E.from $ \ (recip `E.InnerJoin` topic) -> do
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLocalRepoCollab
E.where_ $
recip E.^. CollabRecipLocalPerson E.==. E.val pid E.&&.
topic E.^. CollabTopicLocalRepoRepo E.==. E.val rid
return
( recip E.^. CollabRecipLocalId
, topic E.^. CollabTopicLocalRepoId
, recip E.^. CollabRecipLocalCollab
)
(E.Value crid, E.Value ctid, E.Value cid) <-
case collabs of
[] -> notFound
[c] -> return c
_ -> error "More than 1 collab for repo+person"
deleteWhere [CollabRoleLocalCollab ==. cid]
delete ctid
deleteWhere [CollabSenderLocalCollab ==. cid]
deleteWhere [CollabSenderRemoteCollab ==. cid]
delete crid
delete cid delete cid
setMessage "Collaborator removed." setMessage "Collaborator removed."
redirect $ RepoDevsR shr rp redirect $ RepoDevsR shr rp

40
src/Vervis/Migration.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2018, 2019, 2020, 2021, 2022
- by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -1785,6 +1786,43 @@ changes hLocal ctx =
update rid [Repo282Vcs =. vcs] update rid [Repo282Vcs =. vcs]
-- 283 -- 283
, addFieldPrimRequired "Patch" ("???" :: Text) "type" , addFieldPrimRequired "Patch" ("???" :: Text) "type"
-- 284
, addEntities model_2022_06_14
-- 285
, unchecked $ lift $ do
rcs <- selectList ([] :: [Filter RepoCollab285]) []
for_ rcs $ \ (Entity _ (RepoCollab285 rid pid mrlid)) -> do
cid <- insert Collab285
for_ mrlid $ \ rlid -> insert_ $ CollabRoleLocal285 cid rlid
insert_ $ CollabTopicLocalRepo285 cid rid
obiid <- do
r <- getJust rid
insert $
OutboxItem285
(repo285Outbox r)
(persistJSONObjectFromDoc $ Doc hLocal emptyActivity)
defaultTime
insert_ $ CollabSenderLocal285 cid obiid
insert_ $ CollabRecipLocal285 cid pid
jcs <- selectList ([] :: [Filter ProjectCollab285]) []
for_ jcs $ \ (Entity _ (ProjectCollab285 jid pid mrlid)) -> do
cid <- insert Collab285
for_ mrlid $ \ rlid -> insert_ $ CollabRoleLocal285 cid rlid
insert_ $ CollabTopicLocalProject285 cid jid
obiid <- do
j <- getJust jid
insert $
OutboxItem285
(project285Outbox j)
(persistJSONObjectFromDoc $ Doc hLocal emptyActivity)
defaultTime
insert_ $ CollabSenderLocal285 cid obiid
insert_ $ CollabRecipLocal285 cid pid
-- 286
, removeEntity "RepoCollab"
-- 287
, removeEntity "ProjectCollab"
] ]
migrateDB migrateDB

22
src/Vervis/Migration/Model.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>. - Written in 2018, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -245,6 +245,20 @@ module Vervis.Migration.Model
, Patch280Generic (..) , Patch280Generic (..)
, Repo282 , Repo282
, Repo282Generic (..) , Repo282Generic (..)
, model_2022_06_14
, Collab285Generic (..)
, CollabRecipLocal285Generic (..)
, CollabRoleLocal285Generic (..)
, CollabSenderLocal285Generic (..)
, CollabTopicLocalProject285Generic (..)
, CollabTopicLocalRepo285Generic (..)
, OutboxItem285Generic (..)
, Project285Generic (..)
, ProjectCollab285
, ProjectCollab285Generic (..)
, Repo285Generic (..)
, RepoCollab285
, RepoCollab285Generic (..)
) )
where where
@ -481,3 +495,9 @@ makeEntitiesMigration "280"
makeEntitiesMigration "282" makeEntitiesMigration "282"
$(modelFile "migrations/2020_08_13_vcs.model") $(modelFile "migrations/2020_08_13_vcs.model")
model_2022_06_14 :: [Entity SqlBackend]
model_2022_06_14 = $(schema "2022_06_14_collab")
makeEntitiesMigration "285"
$(modelFile "migrations/2022_06_14_collab_mig.model")

2
vervis.cabal
View file

@ -445,7 +445,7 @@ test-suite test
TupleSections TupleSections
build-depends: base build-depends: base
, vervis , vervis
, yesod-test >= 1.5.0.1 && < 1.6 , yesod-test
, yesod-core , yesod-core
, yesod , yesod
, persistent , persistent