mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-14 21:56:20 +09:00
716 lines
27 KiB
Haskell
716 lines
27 KiB
Haskell
{- 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")])
|
|
-}
|