vervis/src/Vervis/Handler/Project.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.Project
    ( getProjectsR
    , postProjectsR
    , getProjectNewR
    , getProjectR
    , putProjectR
    , postProjectR
    , getProjectEditR
    , getProjectDevsR
    , postProjectDevsR
    , getProjectDevNewR
    , getProjectDevR
    , deleteProjectDevR
    , postProjectDevR
    , getProjectTeamR
    , getProjectFollowersR
    )
where

import Control.Monad
import Control.Monad.Trans.Except
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Esqueleto hiding (delete, (%), (==.))
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)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)

import qualified Database.Esqueleto as E

import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..))
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.MonadSite

import qualified Web.ActivityPub as AP

import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Database.Persist.Local
import Yesod.Persist.Local

import Vervis.API
import Vervis.Client
import Vervis.Federation
import Vervis.Form.Project
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Development.PatchMediaType
import Vervis.Settings
import Vervis.Widget.Project
import Vervis.Widget.Sharer
import Vervis.Widget.Workflow

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

postProjectsR :: ShrIdent -> Handler Html
postProjectsR shr = do
    ep@(Entity _ p) <- requireAuth
    Entity sid s <- runDB $ do
        _ <- getBy404 $ UniqueSharer shr
        getJustEntity $ personIdent p
    unless (sharerIdent s == shr) $
        invalidArgs ["Trying to create project under someone/something else"]
    ((result, widget), enctype) <- runFormPost $ newProjectForm sid
    eprj <- runExceptT $ do
        NewProject name mdesc _ _ <-
            case result of
                FormSuccess np -> return np
                FormMissing -> throwE "Field(s) missing"
                FormFailure _l -> throwE "Project creation failed, see below"
        (msummary, audience, detail, mtarget) <- lift $ createDeck shr name mdesc
        obiidCreate <- createTicketTrackerC ep s msummary audience detail mtarget
        runDBExcept $ do
            mj <- lift $ getValBy $ UniqueProjectCreate obiidCreate
            projectIdent <$> fromMaybeE mj "New project not found"
    case eprj of
        Left e -> do
            setMessage $ toHtml e
            defaultLayout $(widgetFile "project/new")
        Right prj -> do
            setMessage "Project created!"
            redirect $ ProjectR shr prj

getProjectNewR :: ShrIdent -> Handler Html
getProjectNewR shr = do
    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
    ((_result, widget), enctype) <- runFormPost $ newProjectForm sid
    defaultLayout $(widgetFile "project/new")

getProjectR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectR shar proj = do
    (actor, project, workflow, wsharer, repos) <- runDB $ do
        Entity sid s <- getBy404 $ UniqueSharer shar
        Entity pid p <- getBy404 $ UniqueProject proj sid
        w <- get404 $ projectWorkflow p
        sw <-
            if workflowSharer w == sid
                then return s
                else get404 $ workflowSharer w
        rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
        a <- getJust $ projectActor p
        return (a, p, w, sw, rs)

    route2fed <- getEncodeRouteHome
    route2local <- getEncodeRouteLocal
    let projectAP = AP.TicketTracker
            { AP.ticketTrackerActor = AP.Actor
                { AP.actorLocal = AP.ActorLocal
                    { AP.actorId         = route2local $ ProjectR shar proj
                    , AP.actorInbox      = route2local $ ProjectInboxR shar proj
                    , AP.actorOutbox     =
                        Just $ route2local $ ProjectOutboxR shar proj
                    , AP.actorFollowers  =
                        Just $ route2local $ ProjectFollowersR shar proj
                    , AP.actorFollowing  = Nothing
                    , AP.actorPublicKeys =
                        [ Left $ route2local ActorKey1R
                        , Left $ route2local ActorKey2R
                        ]
                    , AP.actorSshKeys    = []
                    }
                , AP.actorDetail = AP.ActorDetail
                    { AP.actorType       = ActorTypeTicketTracker
                    , AP.actorUsername   = Nothing
                    , AP.actorName       =
                        Just $ fromMaybe (prj2text proj) $ projectName project
                    , AP.actorSummary    = projectDesc project
                    }
                }
            , AP.ticketTrackerTeam = route2local $ ProjectTeamR shar proj
            }
        followButton =
            followW
                (ProjectFollowR shar proj)
                (ProjectUnfollowR shar proj)
                (return $ actorFollowers actor)
    provideHtmlAndAP projectAP $(widgetFile "project/one")

putProjectR :: ShrIdent -> PrjIdent -> Handler Html
putProjectR shr prj = do
    (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")

postProjectR :: ShrIdent -> PrjIdent -> Handler Html
postProjectR shr prj = do
    mmethod <- lookupPostParam "_method"
    case mmethod of
        Just "PUT" -> putProjectR shr prj
        _          -> notFound

getProjectEditR :: ShrIdent -> PrjIdent -> Handler Html
getProjectEditR shr prj = do
    (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")

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

getProjectFollowersR :: ShrIdent -> PrjIdent -> Handler TypedContent
getProjectFollowersR shr prj = getFollowersCollection here getFsid
    where
    here = ProjectFollowersR shr prj
    getFsid = do
        sid <- getKeyBy404 $ UniqueSharer shr
        j <- getValBy404 $ UniqueProject prj sid
        a <- getJust $ projectActor j
        return $ actorFollowers a