vervis/src/Vervis/Handler/Project.hs

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

import Prelude

import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Database.Persist
import Database.Esqueleto hiding (delete, (%), (==.))
import Text.Blaze.Html (Html)
import Yesod.Auth (requireAuthId)
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 Network.FedURI
import Web.ActivityPub
import Yesod.FedURI

import Vervis.Form.Project
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Repo
import Vervis.Settings
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
    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
    ((result, widget), enctype) <- runFormPost $ newProjectForm sid
    case result of
        FormSuccess np -> do
            pid <- requireAuthId
            runDB $ do
                let project = Project
                        { projectIdent      = npIdent np
                        , projectSharer     = sid
                        , projectName       = npName np
                        , projectDesc       = npDesc np
                        , projectWorkflow   = npWflow np
                        , projectNextTicket = 1
                        , projectWiki       = Nothing
                        , projectCollabAnon = Nothing
                        , projectCollabUser = Nothing
                        }
                jid <- insert project
                let collab = ProjectCollab
                        { projectCollabProject = jid
                        , projectCollabPerson  = pid
                        , projectCollabRole    = npRole np
                        }
                insert_ collab
            setMessage "Project added."
            redirect $ ProjectR shr (npIdent np)
        FormMissing -> do
            setMessage "Field(s) missing"
            defaultLayout $(widgetFile "project/new")
        FormFailure _l -> do
            setMessage "Project creation failed, see below"
            defaultLayout $(widgetFile "project/new")

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 = selectRep $ do
    provideRep $ do
        (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]
            return (p, w, sw, rs)
        defaultLayout $(widgetFile "project/one")
    provideAP $ do
        project <- runDB $ do
            Entity sid _s <- getBy404 $ UniqueSharer shar
            Entity _pid p <- getBy404 $ UniqueProject proj sid
            return p
        route2fed <- getEncodeRouteFed
        route2local <- getEncodeRouteLocal
        let (host, me) = f2l $ route2fed $ ProjectR shar proj
        return $ Doc host Actor
            { actorId         = me
            , actorType       = ActorTypeProject
            , actorUsername   = Nothing
            , actorName       =
                Just $ fromMaybe (prj2text proj) $ projectName project
            , actorSummary    = projectDesc project
            , actorInbox      = route2local $ ProjectInboxR shar proj
            , actorPublicKeys =
                [ Left $ route2local ActorKey1R
                , Left $ route2local ActorKey2R
                ]
            }

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
        select $ from $ \ (collab `InnerJoin`
                           person `InnerJoin`
                           sharer `LeftOuterJoin`
                           role) -> do
            on $ collab ^. ProjectCollabRole    E.==. role ?. ProjectRoleId
            on $ person ^. PersonIdent          E.==. sharer ^. SharerId
            on $ collab ^. ProjectCollabPerson  E.==. person ^. PersonId
            where_ $ collab ^. ProjectCollabProject E.==. val jid
            return (sharer, role ?. ProjectRoleIdent)
    defaultLayout $(widgetFile "project/collab/list")

postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
postProjectDevsR 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
    case result of
        FormSuccess nc -> do
            runDB $ do
                let collab = ProjectCollab
                        { projectCollabProject = jid
                        , projectCollabPerson  = ncPerson nc
                        , projectCollabRole    = ncRole nc
                        }
                insert_ collab
            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
        Entity _cid collab <- getBy404 $ UniqueProjectCollab jid pid
        fmap projectRoleIdent <$> traverse getJust (projectCollabRole collab)
    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
        Entity cid _collab <- getBy404 $ UniqueProjectCollab jid pid
        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