Implement getTicketTeamR & getTicketParticipantsR (AS2 & HTML showing the JSON)

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|
+                <div><pre>#{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|
+                <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