vervis/src/Vervis/Handler/Deck.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2019, 2022 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






    {-
    , getProjectsR
    , getProjectR
    , putProjectR
    , getProjectDevsR
    , postProjectDevsR
    , getProjectDevNewR
    , getProjectDevR
    , deleteProjectDevR
    , postProjectDevR
    , getProjectTeamR
    -}
    )
where

import Control.Monad
import Control.Monad.Trans.Except
import Data.Aeson
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 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.Ticket
import Vervis.FedURI
import Vervis.Form.Project
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
import Vervis.Recipient
import Vervis.Settings
import Vervis.Ticket
import Vervis.TicketFilter
import Vervis.Web.Actor
import Vervis.Widget.Person
import Vervis.Widget.Ticket

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
            }
        followButton =
            followW
                (DeckFollowR deckHash)
                (DeckUnfollowR deckHash)
                (actorFollowers actor)

    provideHtmlAndAP deckAP $ redirectToPrettyJSON $ DeckR deckHash

getDeckInboxR :: KeyHashid Deck -> Handler TypedContent
getDeckInboxR = getInbox DeckInboxR deckActor

postDeckInboxR :: KeyHashid Deck -> Handler ()
postDeckInboxR recipDeckHash =
    postInbox $ handleRobotInbox (LocalActorDeck recipDeckHash) handle
    where
    handle
        :: UTCTime
        -> RemoteAuthor
        -> ActivityBody
        -> Maybe (RecipientRoutes, ByteString)
        -> LocalURI
        -> SpecificActivity URIMode
        -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
    handle now author body mfwd luActivity specific =
        case specific of
            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
                    _ -> error "Unsupported create object type for decks"
            {-
            FollowActivity follow ->
                (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
            -}
            AP.InviteActivity invite ->
                topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite
            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)
            {-
            ResolveActivity resolve ->
                (,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
            UndoActivity undo ->
                (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor 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
        ((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
        let tf =
                case filtResult of
                    FormSuccess filt -> filt
                    FormMissing      -> def
                    FormFailure l    ->
                        error $ "Ticket filter form failed: " ++ show l
        deckID <- decodeKeyHashid404 deckHash
        (total, pages, mpage) <- runDB $ do
            _ <- get404 deckID
            let countAllTickets = count [TicketDeckDeck ==. deckID]
                selectTickets off lim =
                    getTicketSummaries
                        (filterTickets tf)
                        (Just $ \ t -> [E.desc $ t E.^. TicketId])
                        (Just (off, lim))
                        deckID
            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]
                    }
                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 newProjectForm
    defaultLayout $(widgetFile "project/new")

postDeckNewR :: Handler Html
postDeckNewR = do
    NewProject name desc <- runFormPostRedirect DeckNewR newProjectForm

    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
    actor <- runDB $ getJust $ personActor person
    result <-
        runExceptT $ createTicketTrackerC personEntity actor Nothing localRecips remoteRecips fwdHosts action detail Nothing Nothing

    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


























{-
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")

getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
getProjectDevsR shr prj = do
    devs <- runDB $ do
        jid <- do
            Entity sid _ <- getBy404 $ UniqueSharer shr
            Entity jid _ <- getBy404 $ UniqueProject prj sid
            return jid
        E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` sharer `E.LeftOuterJoin` (crole `E.InnerJoin` role)) -> do
            E.on $ crole E.?. CollabRoleLocalRole E.==. role E.?. RoleId
            E.on $ E.just (recip E.^. CollabRecipLocalCollab) E.==. crole E.?. CollabRoleLocalCollab
            E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
            E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId
            E.on $ topic E.^. CollabTopicLocalProjectCollab E.==. recip E.^. CollabRecipLocalCollab
            E.where_ $ topic E.^. CollabTopicLocalProjectProject E.==. E.val jid
            return (sharer, role E.?. RoleIdent)
    defaultLayout $(widgetFile "project/collab/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
            }
    provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")])
-}