{- This file is part of Vervis. - - Written in 2016 by fr33domlover . - - ♡ 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 - . -} 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 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 , 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 Entity sid _ <- runDB $ getBy404 $ UniqueSharer shr ((_result, widget), enctype) <- runFormPost $ newProjectForm 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 (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 rp dev = do rl <- 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 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 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