vervis/src/Vervis/Handler/Project.hs

{- This file is part of Vervis.
 -
 - Written in 2016 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 (defaultLayout)
import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound)
import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, getBy404)

import qualified Database.Esqueleto as E

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

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
    pid <- requireAuthId
    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
    ((result, widget), enctype) <- runFormPost $ newProjectForm pid sid
    case result of
        FormSuccess np -> do
            runDB $ do
                let project = Project
                        { projectIdent      = npIdent np
                        , projectSharer     = sid
                        , projectName       = npName np
                        , projectDesc       = npDesc np
                        , projectNextTicket = 1
                        , projectWiki       = 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
    pid <- requireAuthId
    Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr
    ((_result, widget), enctype) <- runFormPost $ newProjectForm pid sid
    defaultLayout $(widgetFile "project/new")

getProjectR :: ShrIdent -> PrjIdent -> Handler Html
getProjectR shar proj = do
    (project, repos) <- runDB $ do
        Entity sid _s <- getBy404 $ UniqueSharer shar
        Entity pid p <- getBy404 $ UniqueProject proj sid
        rs <- selectList [RepoProject ==. Just pid] [Asc RepoIdent]
        return (p, rs)
    defaultLayout $(widgetFile "project/one")

putProjectR :: ShrIdent -> PrjIdent -> Handler Html
putProjectR shr prj = do
    ep@(Entity jid project) <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shr
        getBy404 $ UniqueProject prj sid
    ((result, widget), enctype) <- runFormPost $ editProjectForm 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
    ep <- runDB $ do
        Entity sid _sharer <- getBy404 $ UniqueSharer shr
        getBy404 $ UniqueProject prj sid
    ((_result, widget), enctype) <- runFormPost $ editProjectForm ep
    defaultLayout $(widgetFile "project/edit")

getProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
getProjectDevsR shr rp = do
    devs <- runDB $ do
        rid <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity r _ <- getBy404 $ UniqueProject rp s
            return r
        select $ from $ \ (collab, person, sharer, role) -> do
            where_ $
                collab ^. ProjectCollabProject E.==. val rid            &&.
                collab ^. ProjectCollabPerson  E.==. person ^. PersonId &&.
                person ^. PersonIdent          E.==. sharer ^. SharerId &&.
                collab ^. ProjectCollabRole    E.==. role ^. ProjectRoleId
            return (sharer, role ^. ProjectRoleIdent)
    defaultLayout $(widgetFile "project/collab/list")

postProjectDevsR :: ShrIdent -> PrjIdent -> Handler Html
postProjectDevsR shr rp = do
    (pid, rid) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity p _ <- getBy404 $ UniquePersonIdent s
        Entity r _ <- getBy404 $ UniqueProject rp s
        return (p, r)
    ((result, widget), enctype) <- runFormPost $ newProjectCollabForm pid rid
    case result of
        FormSuccess nc -> do
            runDB $ do
                let collab = ProjectCollab
                        { projectCollabProject = rid
                        , 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
    (pid, rid) <- runDB $ do
        Entity s _ <- getBy404 $ UniqueSharer shr
        Entity p _ <- getBy404 $ UniquePersonIdent s
        Entity r _ <- getBy404 $ UniqueProject rp s
        return (p, r)
    ((_result, widget), enctype) <- runFormPost $ newProjectCollabForm pid rid
    defaultLayout $(widgetFile "project/collab/new")

getProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
getProjectDevR shr rp dev = do
    rl <- runDB $ do
        rid <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity r _ <- getBy404 $ UniqueProject rp s
            return r
        pid <- do
            Entity s _ <- getBy404 $ UniqueSharer dev
            Entity p _ <- getBy404 $ UniquePersonIdent s
            return p
        Entity _cid collab <- getBy404 $ UniqueProjectCollab rid pid
        role <- getJust $ projectCollabRole collab
        return $ projectRoleIdent role
    defaultLayout $(widgetFile "project/collab/one")

deleteProjectDevR :: ShrIdent -> PrjIdent -> ShrIdent -> Handler Html
deleteProjectDevR shr rp dev = do
    runDB $ do
        rid <- do
            Entity s _ <- getBy404 $ UniqueSharer shr
            Entity r _ <- getBy404 $ UniqueProject rp s
            return r
        pid <- do
            Entity s _ <- getBy404 $ UniqueSharer dev
            Entity p _ <- getBy404 $ UniquePersonIdent s
            return p
        Entity cid _collab <- getBy404 $ UniqueProjectCollab rid 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