diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 4961ee2..3acad65 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -58,6 +58,7 @@ import Prelude import Control.Applicative (liftA2) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (logWarn) +import Data.Bifunctor import Data.Bool (bool) import Data.Default.Class (def) import Data.Foldable (traverse_) @@ -82,9 +83,16 @@ import qualified Data.Text as T (filter, intercalate, pack) import qualified Database.Esqueleto as E 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 Data.Maybe.Local (partitionMaybePairs) +import Database.Persist.Local +import Yesod.Persist.Local import Vervis.Form.Ticket import Vervis.Foundation @@ -779,7 +787,98 @@ getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketReverseDepsR = getTicketDeps False 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| +
#{encodePrettyToLazyText doc} + |] 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| +#{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