{- 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.Deck
( getDeckR
, getDeckInboxR
, postDeckInboxR
, getDeckOutboxR
, getDeckOutboxItemR
, getDeckFollowersR
, getDeckTicketsR
, getDeckTreeR
, getDeckMessageR
, getDeckNewR
, postDeckNewR
, postDeckDeleteR
, getDeckEditR
, postDeckEditR
, postDeckFollowR
, postDeckUnfollowR
, getDeckStampR
, getDeckCollabsR
, getDeckInviteR
, postDeckInviteR
, postDeckRemoveR
{-
, getProjectsR
, getProjectR
, putProjectR
, postProjectDevsR
, getProjectDevNewR
, getProjectDevR
, deleteProjectDevR
, postProjectDevR
, getProjectTeamR
-}
)
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
getDeckR :: KeyHashid Deck -> Handler TypedContent
getDeckR deckHash = do
deckID <- decodeKeyHashid404 deckHash
(deck, repoIDs, actor, sigKeyIDs) <- runDB $ do
d <- get404 deckID
rs <- selectKeysList [RepoProject ==. Just deckID] [Asc RepoId]
let aid = deckActor d
a <- getJust aid
sigKeys <- selectKeysList [SigKeyActor ==. aid] [Asc SigKeyId]
return (d, rs, a, sigKeys)
encodeRouteLocal <- getEncodeRouteLocal
hashSigKey <- getEncodeKeyHashid
perActor <- asksSite $ appPerActorKeys . appSettings
let deckAP = AP.TicketTracker
{ AP.ticketTrackerActor = AP.Actor
{ AP.actorLocal = AP.ActorLocal
{ AP.actorId = encodeRouteLocal $ DeckR deckHash
, AP.actorInbox = encodeRouteLocal $ DeckInboxR deckHash
, AP.actorOutbox =
Just $ encodeRouteLocal $ DeckOutboxR deckHash
, AP.actorFollowers =
Just $ encodeRouteLocal $ DeckFollowersR deckHash
, AP.actorFollowing = Nothing
, AP.actorPublicKeys =
map (Left . encodeRouteLocal) $
if perActor
then map (DeckStampR deckHash . hashSigKey) sigKeyIDs
else [ActorKey1R, ActorKey2R]
, AP.actorSshKeys = []
}
, AP.actorDetail = AP.ActorDetail
{ AP.actorType = ActorTypeTicketTracker
, AP.actorUsername = Nothing
, AP.actorName = Just $ actorName actor
, AP.actorSummary = Just $ actorDesc actor
}
}
, AP.ticketTrackerTeam = Nothing
, AP.ticketTrackerCollaborators =
encodeRouteLocal $ DeckCollabsR deckHash
}
followButton =
followW
(DeckFollowR deckHash)
(DeckUnfollowR deckHash)
(actorFollowers actor)
provideHtmlAndAP deckAP $ redirect $ DeckTicketsR deckHash
getDeckInboxR :: KeyHashid Deck -> Handler TypedContent
getDeckInboxR = getInbox DeckInboxR deckActor
postDeckInboxR :: KeyHashid Deck -> Handler ()
postDeckInboxR deckHash = do
deckID <- decodeKeyHashid404 deckHash
postInbox $ LocalActorDeck deckID
{-
AP.AcceptActivity accept ->
deckAcceptF now recipDeckHash author body mfwd luActivity accept
AP.CreateActivity (AP.Create obj mtarget) ->
case obj of
AP.CreateNote _ note ->
(,Nothing) <$> deckCreateNoteF now recipDeckHash author body mfwd luActivity note
_ -> return ("Unsupported create object type for decks", Nothing)
AP.FollowActivity follow ->
deckFollowF now recipDeckHash author body mfwd luActivity follow
AP.InviteActivity invite ->
topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite
AP.JoinActivity join ->
deckJoinF now recipDeckHash author body mfwd luActivity join
OfferActivity (Offer obj target) ->
case obj of
OfferTicket ticket ->
(,Nothing) <$> deckOfferTicketF now recipDeckHash author body mfwd luActivity ticket target
{-
OfferDep dep ->
projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
-}
_ -> return ("Unsupported offer object type for decks", Nothing)
AP.ResolveActivity resolve ->
deckResolveF now recipDeckHash author body mfwd luActivity resolve
AP.UndoActivity undo ->
(,Nothing) <$> deckUndoF now recipDeckHash author body mfwd luActivity undo
_ -> return ("Unsupported activity type for decks", Nothing)
-}
getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent
getDeckOutboxR = getOutbox DeckOutboxR DeckOutboxItemR deckActor
getDeckOutboxItemR
:: KeyHashid Deck -> KeyHashid OutboxItem -> Handler TypedContent
getDeckOutboxItemR = getOutboxItem DeckOutboxItemR deckActor
getDeckFollowersR :: KeyHashid Deck -> Handler TypedContent
getDeckFollowersR = getActorFollowersCollection DeckFollowersR deckActor
getDeckTicketsR :: KeyHashid Deck -> Handler TypedContent
getDeckTicketsR deckHash = selectRep $ do
provideRep $ do
let tf = def
{-
((filtResult, filtWidget), filtEnctype) <- runFormPost ticketFilterForm
let tf =
case filtResult of
FormSuccess filt -> filt
FormMissing -> def
FormFailure l ->
error $ "Ticket filter form failed: " ++ show l
-}
deckID <- decodeKeyHashid404 deckHash
(deck, actor, (total, pages, mpage)) <- runDB $ do
deck <- get404 deckID
actor <- getJust $ deckActor deck
let countAllTickets = count [TicketDeckDeck ==. deckID]
selectTickets off lim =
getTicketSummaries
(filterTickets tf)
(Just $ \ t -> [E.desc $ t E.^. TicketId])
(Just (off, lim))
deckID
(deck,actor,) <$> getPageAndNavCount countAllTickets selectTickets
case mpage of
Nothing -> redirectFirstPage here
Just (rows, navModel) ->
let pageNav = navWidget navModel
in defaultLayout $(widgetFile "ticket/list")
provideAP' $ do
deckID <- decodeKeyHashid404 deckHash
(total, pages, mpage) <- runDB $ do
_ <- get404 deckID
let countAllTickets = count [TicketDeckDeck ==. deckID]
selectTickets off lim =
selectKeysList
[TicketDeckDeck ==. deckID]
[OffsetBy off, LimitTo lim, Desc TicketDeckTicket]
getPageAndNavCount countAllTickets selectTickets
encodeRouteHome <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal
hashTicket <- getEncodeKeyHashid
encodeRoutePageLocal <- getEncodeRoutePageLocal
let pageUrl = encodeRoutePageLocal here
host <- asksSite siteInstanceHost
return $
case mpage of
Nothing -> encodeStrict $ Doc host $ Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeOrdered
, collectionTotalItems = Just total
, collectionCurrent = Nothing
, collectionFirst = Just $ pageUrl 1
, collectionLast = Just $ pageUrl pages
, collectionItems = [] :: [Text]
, collectionContext = Nothing
}
Just (tickets, navModel) ->
let current = nmCurrent navModel
in encodeStrict $ Doc host $ CollectionPage
{ collectionPageId = pageUrl current
, collectionPageType = CollectionPageTypeOrdered
, collectionPageTotalItems = Nothing
, collectionPageCurrent = Just $ pageUrl current
, collectionPageFirst = Just $ pageUrl 1
, collectionPageLast = Just $ pageUrl pages
, collectionPagePartOf = encodeRouteLocal here
, collectionPagePrev =
if current > 1
then Just $ pageUrl $ current - 1
else Nothing
, collectionPageNext =
if current < pages
then Just $ pageUrl $ current + 1
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems =
encodeRouteHome . TicketR deckHash . hashTicket <$> tickets
}
where
here = DeckTicketsR deckHash
encodeStrict = BL.toStrict . encode
getDeckTreeR :: KeyHashid Deck -> Handler Html
getDeckTreeR _ = error "Temporarily disabled"
{-
(summaries, deps) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid
(,) <$> getTicketSummaries Nothing Nothing Nothing jid
<*> getTicketDepEdges jid
defaultLayout $ ticketTreeDW shr prj summaries deps
-}
getDeckMessageR :: KeyHashid Deck -> KeyHashid LocalMessage -> Handler Html
getDeckMessageR _ _ = notFound
getDeckNewR :: Handler Html
getDeckNewR = do
((_result, widget), enctype) <- runFormPost newDeckForm
defaultLayout $(widgetFile "deck/new")
postDeckNewR :: Handler Html
postDeckNewR = do
NewDeck name desc <- runFormPostRedirect DeckNewR newDeckForm
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
(maybeSummary, audience, detail) <- C.createDeck personHash name desc
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTicketTracker detail Nothing) Nothing
result <-
runExceptT $
handleViaActor personID Nothing localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
redirect DeckNewR
Right createID -> do
maybeDeckID <- runDB $ getKeyBy $ UniqueDeckCreate createID
case maybeDeckID of
Nothing -> error "Can't find the newly created deck"
Just deckID -> do
deckHash <- encodeKeyHashid deckID
setMessage "New ticket tracker created"
redirect $ DeckR deckHash
postDeckDeleteR :: KeyHashid Deck -> Handler Html
postDeckDeleteR _ = error "Temporarily disabled"
getDeckEditR :: KeyHashid Deck -> Handler Html
getDeckEditR _ = do
error "Temporarily disabled"
{-
(sid, ep) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
ep <- getBy404 $ UniqueProject prj sid
return (sid, ep)
((_result, widget), enctype) <- runFormPost $ editProjectForm sid ep
defaultLayout $(widgetFile "project/edit")
-}
postDeckEditR :: KeyHashid Deck -> Handler Html
postDeckEditR _ = do
error "Temporarily disabled"
{-
(sid, ep@(Entity jid _)) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr
eproj <- getBy404 $ UniqueProject prj sid
return (sid, eproj)
((result, widget), enctype) <- runFormPost $ editProjectForm sid ep
case result of
FormSuccess project' -> do
runDB $ replace jid project'
setMessage "Project updated."
redirect $ ProjectR shr prj
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "project/edit")
FormFailure _l -> do
setMessage "Project update failed, see errors below."
defaultLayout $(widgetFile "project/edit")
-}
postDeckFollowR :: KeyHashid Deck -> Handler ()
postDeckFollowR _ = error "Temporarily disabled"
postDeckUnfollowR :: KeyHashid Deck -> Handler ()
postDeckUnfollowR _ = error "Temporarily disabled"
getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent
getDeckStampR = servePerActorKey deckActor LocalActorDeck
getDeckCollabsR :: KeyHashid Deck -> Handler Html
getDeckCollabsR deckHash = do
deckID <- decodeKeyHashid404 deckHash
(deck, actor, collabs, invites, joins) <- runDB $ do
deck <- get404 deckID
actor <- getJust $ deckActor deck
collabs <- do
grants <-
getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
for grants $ \ (role, actor, ct, time) ->
(,role,ct,time) <$> getPersonWidgetInfo actor
invites <- do
invites' <-
getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
for invites' $ \ (inviter, recip, time, role) -> (,,,)
<$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
<*> getPersonWidgetInfo recip
<*> pure time
<*> pure role
joins <- do
joins' <-
getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID
for joins' $ \ (recip, time, role) ->
(,time,role) <$> getPersonWidgetInfo recip
return (deck, actor, collabs, invites, joins)
defaultLayout $(widgetFile "deck/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"
getDeckInviteR :: KeyHashid Deck -> Handler Html
getDeckInviteR deckHash = do
deckID <- decodeKeyHashid404 deckHash
((_result, widget), enctype) <- runFormPost $ deckInviteForm deckID
defaultLayout $(widgetFile "deck/collab/new")
postDeckInviteR :: KeyHashid Deck -> Handler Html
postDeckInviteR deckHash = do
deckID <- decodeKeyHashid404 deckHash
DeckInvite recipPersonID role <-
runFormPostRedirect (DeckInviteR deckHash) $ deckInviteForm deckID
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
uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
C.invite personID uRecipient uResourceCollabs role
grantID <- do
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people"
grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
let cap =
Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
handleViaActor
personID (Just cap) localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
redirect $ DeckInviteR deckHash
Right inviteID -> do
setMessage "Invite sent"
redirect $ DeckCollabsR deckHash
postDeckRemoveR :: KeyHashid Deck -> CollabTopicDeckId -> Handler Html
postDeckRemoveR deckHash ctID = do
deckID <- decodeKeyHashid404 deckHash
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID
encodeRouteHome <- getEncodeRouteHome
result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do
CollabTopicDeck collabID deckID' <- MaybeT $ get ctID
guard $ deckID' == deckID
_ <- 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 uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
C.remove personID uRecipient uResourceCollabs
grantID <- do
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
(localRecips, remoteRecips, fwdHosts, action) <-
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
let cap =
Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
handleViaActor
personID (Just cap) localRecips remoteRecips fwdHosts action
case result of
Left e -> do
setMessage $ toHtml e
Right removeID -> do
setMessage "Remove sent"
redirect $ DeckCollabsR deckHash
{-
getProjectsR :: ShrIdent -> Handler Html
getProjectsR ident = do
projects <- runDB $ select $ from $ \ (sharer, project) -> do
where_ $
sharer ^. SharerIdent E.==. val ident &&.
sharer ^. SharerId E.==. project ^. ProjectSharer
orderBy [asc $ project ^. ProjectIdent]
return $ project ^. ProjectIdent
defaultLayout $(widgetFile "project/list")
postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
postProjectDevsR shr rp = do
(sid, jid, obid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid j <- getBy404 $ UniqueProject rp sid
a <- getJust $ projectActor j
return (sid, jid, actorOutbox a)
((result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
case result of
FormSuccess nc -> do
now <- liftIO getCurrentTime
host <- asksSite siteInstanceHost
runDB $ do
obiid <-
insert $
OutboxItem
obid
(persistJSONObjectFromDoc $ Doc host emptyActivity)
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."
redirect $ ProjectDevsR shr rp
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "project/collab/new")
FormFailure _l -> do
setMessage "Operation failed, see errors below"
defaultLayout $(widgetFile "project/collab/new")
getProjectDevNewR :: ShrIdent -> PrjIdent -> Handler Html
getProjectDevNewR shr rp = do
(sid, jid) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject rp s
return (s, j)
((_result, widget), enctype) <- runFormPost $ newProjectCollabForm sid jid
defaultLayout $(widgetFile "project/collab/new")
getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
getProjectDevR shr prj dev = do
mrl <- runDB $ do
jid <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s
return j
pid <- do
Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s
return p
l <- E.select $ E.from $ \ (topic `E.InnerJoin` recip) -> do
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")
deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
deleteProjectDevR shr rp dev = do
runDB $ do
jid <- do
Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject rp s
return j
pid <- do
Entity s _ <- getBy404 $ UniqueSharer dev
Entity p _ <- getBy404 $ UniquePersonIdent s
return p
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
setMessage "Collaborator removed."
redirect $ ProjectDevsR shr rp
postProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
postProjectDevR shr rp dev = do
mmethod <- lookupPostParam "_method"
case mmethod of
Just "DELETE" -> deleteProjectDevR shr rp dev
_ -> notFound
getProjectTeamR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectTeamR shr prj = do
memberShrs <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
_jid <- getKeyBy404 $ UniqueProject prj sid
id_ <-
requireEitherAlt
(getKeyBy $ UniquePersonIdent sid)
(getKeyBy $ UniqueGroup sid)
"Found sharer that is neither person nor group"
"Found sharer that is both person and group"
case id_ of
Left pid -> return [shr]
Right gid -> do
pids <-
map (groupMemberPerson . entityVal) <$>
selectList [GroupMemberGroup ==. gid] []
sids <-
map (personIdent . entityVal) <$>
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
let here = ProjectTeamR shr prj
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let team = Collection
{ collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered
, collectionTotalItems = Just $ length memberShrs
, collectionCurrent = Nothing
, collectionFirst = Nothing
, collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
, collectionContext = Nothing
}
provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
-}