Implement getTicketTeamR & getTicketParticipantsR (AS2 & HTML showing the JSON)
This commit is contained in:
fr33domlover
parent
ae1e10cab2
commit
b7e2776e6a
1 changed files with 101 additions and 2 deletions
|
|
@ -58,6 +58,7 @@ import Prelude
|
||||||
import Control.Applicative (liftA2)
|
import Control.Applicative (liftA2)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Monad.Logger (logWarn)
|
import Control.Monad.Logger (logWarn)
|
||||||
|
import Data.Bifunctor
|
||||||
import Data.Bool (bool)
|
import Data.Bool (bool)
|
||||||
import Data.Default.Class (def)
|
import Data.Default.Class (def)
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
|
|
@ -82,9 +83,16 @@ import qualified Data.Text as T (filter, intercalate, pack)
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
|
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
|
||||||
|
|
||||||
|
import Data.Aeson.Encode.Pretty.ToEncoding
|
||||||
|
import Network.FedURI
|
||||||
|
import Web.ActivityPub
|
||||||
|
import Yesod.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
|
|
||||||
import Data.Maybe.Local (partitionMaybePairs)
|
import Data.Maybe.Local (partitionMaybePairs)
|
||||||
|
import Database.Persist.Local
|
||||||
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
import Vervis.Form.Ticket
|
import Vervis.Form.Ticket
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
|
|
@ -779,7 +787,98 @@ getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html
|
||||||
getTicketReverseDepsR = getTicketDeps False
|
getTicketReverseDepsR = getTicketDeps False
|
||||||
|
|
||||||
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
getTicketParticipantsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||||||
getTicketParticipantsR = error "TODO implement getTicketParticipantsR"
|
getTicketParticipantsR shr prj num = do
|
||||||
|
(locals, remotes) <- runDB $ do
|
||||||
|
sid <- getKeyBy404 $ UniqueSharer shr
|
||||||
|
jid <- getKeyBy404 $ UniqueProject prj sid
|
||||||
|
t <- getValBy404 $ UniqueTicket jid num
|
||||||
|
let fsid = ticketFollowers t
|
||||||
|
(,) <$> do pids <- map (followPerson . entityVal) <$>
|
||||||
|
selectList [FollowTarget ==. fsid] []
|
||||||
|
sids <-
|
||||||
|
map (personIdent . entityVal) <$>
|
||||||
|
selectList [PersonId <-. pids] []
|
||||||
|
map (sharerIdent . entityVal) <$>
|
||||||
|
selectList [SharerId <-. sids] []
|
||||||
|
<*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
|
||||||
|
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
|
||||||
|
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
|
||||||
|
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
|
||||||
|
return
|
||||||
|
( i E.^. InstanceHost
|
||||||
|
, ra E.^. RemoteActorIdent
|
||||||
|
)
|
||||||
|
|
||||||
|
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
let doc = Doc hLocal Collection
|
||||||
|
{ collectionId =
|
||||||
|
encodeRouteLocal $ TicketParticipantsR shr prj num
|
||||||
|
, collectionType = CollectionTypeUnordered
|
||||||
|
, collectionTotalItems = Just $ length locals + length remotes
|
||||||
|
, collectionCurrent = Nothing
|
||||||
|
, collectionFirst = Nothing
|
||||||
|
, collectionLast = Nothing
|
||||||
|
, collectionItems =
|
||||||
|
map (encodeRouteHome . SharerR) locals ++
|
||||||
|
map (uncurry l2f . bimap E.unValue E.unValue) remotes
|
||||||
|
}
|
||||||
|
selectRep $ do
|
||||||
|
provideAP $ pure doc
|
||||||
|
provideRep $ defaultLayout $
|
||||||
|
[whamlet|
|
||||||
|
<div><pre>#{encodePrettyToLazyText doc}
|
||||||
|
|]
|
||||||
|
|
||||||
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
|
||||||
getTicketTeamR = error "TODO implement getTicketTeamR"
|
getTicketTeamR shr prj num = do
|
||||||
|
memberShrs <- runDB $ do
|
||||||
|
sid <- getKeyBy404 $ UniqueSharer shr
|
||||||
|
_jid <- getKeyBy404 $ UniqueProject prj sid
|
||||||
|
_tid <- getKeyBy404 $ UniqueTicket _jid num
|
||||||
|
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] []
|
||||||
|
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
let doc = Doc hLocal Collection
|
||||||
|
{ collectionId = encodeRouteLocal $ TicketTeamR shr prj num
|
||||||
|
, collectionType = CollectionTypeUnordered
|
||||||
|
, collectionTotalItems = Just $ length memberShrs
|
||||||
|
, collectionCurrent = Nothing
|
||||||
|
, collectionFirst = Nothing
|
||||||
|
, collectionLast = Nothing
|
||||||
|
, collectionItems = map (encodeRouteHome . SharerR) memberShrs
|
||||||
|
}
|
||||||
|
selectRep $ do
|
||||||
|
provideAP $ pure doc
|
||||||
|
provideRep $ defaultLayout $
|
||||||
|
[whamlet|
|
||||||
|
<div><pre>#{encodePrettyToLazyText doc}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
requireEitherAlt
|
||||||
|
:: Applicative f
|
||||||
|
=> f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)
|
||||||
|
requireEitherAlt get1 get2 errNone errBoth = liftA2 mk get1 get2
|
||||||
|
where
|
||||||
|
mk Nothing Nothing = error errNone
|
||||||
|
mk (Just _) (Just _) = error errBoth
|
||||||
|
mk (Just x) Nothing = Left x
|
||||||
|
mk Nothing (Just y) = Right y
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue