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